From ae4efc73096c9e97b9be13e46dcf7630b2299e8b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 5 Apr 2021 17:54:44 -0600 Subject: [PATCH 01/14] abstractification --- persistent/ChangeLog.md | 16 +- persistent/Database/Persist/Quasi.hs | 832 +----------------- persistent/Database/Persist/Sql.hs | 2 +- persistent/Database/Persist/Sql/Migration.hs | 1 + .../Persist/Sql/Orphan/PersistQuery.hs | 4 +- .../Persist/Sql/Orphan/PersistStore.hs | 1 + .../Persist/Sql/Orphan/PersistUnique.hs | 2 +- persistent/Database/Persist/Sql/Raw.hs | 1 + persistent/Database/Persist/Sql/Run.hs | 2 +- persistent/Database/Persist/Sql/Types.hs | 2 +- persistent/Database/Persist/Sql/Util.hs | 3 +- persistent/persistent.cabal | 18 +- 12 files changed, 36 insertions(+), 848 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 87913f4d3..4cb4da320 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for persistent +## 2.13.0.0 (unreleased) + +* [#]() + * The fields and constructor for `SqlBackend` are no longer exported by + default. They are available from an internal module, + `Database.Persist.Sql.Types.Internal`. Breaking changes from `Internal` + modules are not reflected in the major version. This will allow us to + release new functionality without breaking your code. It's recommended to + switch to using the smart constructor functions and setter functions that + are now exported from `Database.Persist.Sql` instead. + * Previously hidden modules are now exposed under the `Internal` namespace. + ## 2.12.0.2 * [#1123](https://github.com/yesodweb/persistent/pull/1223) @@ -22,10 +34,10 @@ * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`. * [#1207](https://github.com/yesodweb/persistent/pull/1207) * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state. - @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. + @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug. Fortunately, this doesn't affect the public API, and can be a mere bug release. - * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. + * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`. * Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203) * [#1214](https://github.com/yesodweb/persistent/pull/1214): diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index c97860c06..ba0768bc0 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -419,838 +419,8 @@ module Database.Persist.Quasi , upperCaseSettings , lowerCaseSettings , nullable -#if TEST - , Token (..) - , Line' (..) - , preparse - , parseLine - , parseFieldType - , associateLines - , skipEmpty - , LinesWithComments(..) - , splitExtras - , takeColsEx -#endif ) where import Prelude hiding (lines) -import Control.Applicative ( Alternative((<|>)) ) -import Control.Arrow ((&&&)) -import Control.Monad (msum, mplus) -import Data.Char ( isLower, isSpace, isUpper, toLower ) -import Data.List (find, foldl') -import qualified Data.List.NonEmpty as NEL -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) -import Data.Monoid (mappend) -#if !MIN_VERSION_base(4,11,0) --- This can be removed when GHC < 8.2.2 isn't supported anymore -import Data.Semigroup ((<>)) -#endif -import Data.Text (Text) -import qualified Data.Text as T -import Database.Persist.Types -import Text.Read (readEither) - -data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show - -parseFieldType :: Text -> Either String FieldType -parseFieldType t0 = - case parseApplyFT t0 of - PSSuccess ft t' - | T.all isSpace t' -> Right ft - PSFail err -> Left $ "PSFail " ++ err - other -> Left $ show other - where - parseApplyFT t = - case goMany id t of - PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' - PSSuccess [] _ -> PSFail "empty" - PSFail err -> PSFail err - PSDone -> PSDone - - parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType - parseEnclosed end ftMod t = - let (a, b) = T.break (== end) t - in case parseApplyFT a of - PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of - ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') - (x, y) -> PSFail $ show (b, x, y) - x -> PSFail $ show x - - parse1 t = - case T.uncons t of - Nothing -> PSDone - Just (c, t') - | isSpace c -> parse1 $ T.dropWhile isSpace t' - | c == '(' -> parseEnclosed ')' id t' - | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b - | otherwise -> PSFail $ show (c, t') - getCon t = - case T.breakOnEnd "." t of - (_, "") -> FTTypeCon Nothing t - ("", _) -> FTTypeCon Nothing t - (a, b) -> FTTypeCon (Just $ T.init a) b - goMany front t = - case parse1 t of - PSSuccess x t' -> goMany (front . (x:)) t' - PSFail err -> PSFail err - PSDone -> PSSuccess (front []) t - -- _ -> - -data PersistSettings = PersistSettings - { psToDBName :: !(Text -> Text) - , psStrictFields :: !Bool - -- ^ Whether fields are by default strict. Default value: @True@. - -- - -- @since 1.2 - , psIdName :: !Text - -- ^ The name of the id column. Default value: @id@ - -- The name of the id column can also be changed on a per-model basis - -- - -- - -- @since 2.0 - } - -defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings -defaultPersistSettings = PersistSettings - { psToDBName = id - , psStrictFields = True - , psIdName = "id" - } - -upperCaseSettings = defaultPersistSettings - -lowerCaseSettings = defaultPersistSettings - { psToDBName = - let go c - | isUpper c = T.pack ['_', toLower c] - | otherwise = T.singleton c - in T.dropWhile (== '_') . T.concatMap go - } - --- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: PersistSettings -> Text -> [EntityDef] -parse ps = maybe [] (parseLines ps) . preparse - -preparse :: Text -> Maybe (NonEmpty Line) -preparse txt = do - lns <- NEL.nonEmpty (T.lines txt) - NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) - --- TODO: refactor to return (Line' NonEmpty), made possible by --- https://github.com/yesodweb/persistent/pull/1206 but left out --- in order to minimize the diff -parseLine :: Text -> Maybe Line -parseLine txt = - case tokenize txt of - [] -> - Nothing - toks -> - pure $ Line (parseIndentationAmount txt) toks - --- | A token used by the parser. -data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. - | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. - deriving (Show, Eq) - -tokenText :: Token -> Text -tokenText tok = - case tok of - Token t -> t - DocComment t -> "-- | " <> t - -parseIndentationAmount :: Text -> Int -parseIndentationAmount txt = - let (spaces, _) = T.span isSpace txt - in T.length spaces - --- | Tokenize a string. -tokenize :: Text -> [Token] -tokenize t - | T.null t = [] - | Just txt <- T.stripPrefix "-- | " t = [DocComment txt] - | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. - | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) - | T.head t == '"' = quotes (T.tail t) id - | T.head t == '(' = parens 1 (T.tail t) id - | isSpace (T.head t) = - tokenize (T.dropWhile isSpace t) - - -- support mid-token quotes and parens - | Just (beforeEquals, afterEquals) <- findMidToken t - , not (T.any isSpace beforeEquals) - , Token next : rest <- tokenize afterEquals = - Token (T.concat [beforeEquals, "=", next]) : rest - - | otherwise = - let (token, rest) = T.break isSpace t - in Token token : tokenize rest - where - findMidToken t' = - case T.break (== '=') t' of - (x, T.drop 1 -> y) - | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) - _ -> Nothing - - quotes t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated quoted string starting with " : front [] - | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') - | T.head t' == '\\' && T.length t' > 1 = - quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','\"']) t' - in quotes y (front . (x:)) - parens count t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated parens string starting with " : front [] - | T.head t' == ')' = - if count == (1 :: Int) - then Token (T.concat $ front []) : tokenize (T.tail t') - else parens (count - 1) (T.tail t') (front . (")":)) - | T.head t' == '(' = - parens (count + 1) (T.tail t') (front . ("(":)) - | T.head t' == '\\' && T.length t' > 1 = - parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','(',')']) t' - in parens count y (front . (x:)) - --- | A line. We don't care about spaces in the middle of the --- line. Also, we don't care about the amount of indentation. -data Line' f - = Line - { lineIndent :: Int - , tokens :: f Token - } - -deriving instance Show (f Token) => Show (Line' f) -deriving instance Eq (f Token) => Eq (Line' f) - -mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g -mapLine k (Line i t) = Line i (k t) - -traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) -traverseLine k (Line i xs) = Line i <$> k xs - -lineText :: Functor f => Line' f -> f Text -lineText = fmap tokenText . tokens - -type Line = Line' [] - -lowestIndent - :: Functor f - => Foldable f - => Functor g - => f (Line' g) - -> Int -lowestIndent = minimum . fmap lineIndent - --- | Divide lines into blocks and make entity definitions. -parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] -parseLines ps = - fixForeignKeysAll . map mk . associateLines . skipEmpty - where - mk :: LinesWithComments -> UnboundEntityDef - mk lwc = - let ln :| rest = lwcLines lwc - (name :| entAttribs) = lineText ln - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) - -isDocComment :: Token -> Maybe Text -isDocComment tok = - case tok of - DocComment txt -> Just txt - _ -> Nothing - -data LinesWithComments = LinesWithComments - { lwcLines :: NonEmpty (Line' NonEmpty) - , lwcComments :: [Text] - } deriving (Eq, Show) - --- TODO: drop this and use <> when 8.2 isn't supported anymore so the --- monoid/semigroup nonsense isn't annoying -appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments -appendLwc a b = - LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) - -newLine :: Line' NonEmpty -> LinesWithComments -newLine l = LinesWithComments (pure l) [] - -firstLine :: LinesWithComments -> Line' NonEmpty -firstLine = NEL.head . lwcLines - -consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments -consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } - -consComment :: Text -> LinesWithComments -> LinesWithComments -consComment l lwc = lwc { lwcComments = l : lwcComments lwc } - -associateLines :: [Line' NonEmpty] -> [LinesWithComments] -associateLines lines = - foldr combine [] $ - foldr toLinesWithComments [] lines - where - toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments] - toLinesWithComments line linesWithComments = - case linesWithComments of - [] -> - [newLine line] - (lwc : lwcs) -> - case isDocComment (NEL.head (tokens line)) of - Just comment - | lineIndent line == lowestIndent lines -> - consComment comment lwc : lwcs - _ -> - if lineIndent line <= lineIndent (firstLine lwc) - && lineIndent (firstLine lwc) /= lowestIndent lines - then - consLine line lwc : lwcs - else - newLine line : lwc : lwcs - - combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] - combine lwc [] = - [lwc] - combine lwc (lwc' : lwcs) = - let minIndent = minimumIndentOf lwc - otherIndent = minimumIndentOf lwc' - in - if minIndent < otherIndent then - appendLwc lwc lwc' : lwcs - else - lwc : lwc' : lwcs - - - minimumIndentOf = lowestIndent . lwcLines - -skipEmpty :: NonEmpty (Line' []) -> [Line' NonEmpty] -skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) . NEL.toList - -setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef -setComments [] = id -setComments comments = - overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) - -fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] -fixForeignKeysAll unEnts = map fixForeignKeys unEnts - where - ents = map unboundEntityDef unEnts - entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents - - fixForeignKeys :: UnboundEntityDef -> EntityDef - fixForeignKeys (UnboundEntityDef foreigns ent) = - ent { entityForeigns = map (fixForeignKey ent) foreigns } - - -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns - fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = - case mfdefs of - Just fdefs -> - if length foreignFieldTexts /= length fdefs - then - lengthError fdefs - else - let - fds_ffs = - zipWith toForeignFields - foreignFieldTexts - fdefs - dbname = - unEntityNameDB (entityDB pent) - oldDbName = - unEntityNameDB (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - EntityNameDB dbname - , foreignConstraintNameDBName = - ConstraintNameDB - . T.replace oldDbName dbname . unConstraintNameDB - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no primary key found fdef="++show fdef++ " ent="++show ent - where - pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - mfdefs = case parentFieldTexts of - [] -> entitiesPrimary pent - _ -> Just $ map (getFd pent . FieldNameHS) parentFieldTexts - - setNull :: [FieldDef] -> Bool - setNull [] = error "setNull: impossible!" - setNull (fd:fds) = let nullSetting = isNull fd in - if all ((nullSetting ==) . isNull) fds then nullSetting - else error $ "foreign key columns must all be nullable or non-nullable" - ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds)) - isNull = (NotNullable /=) . nullable . fieldAttrs - - toForeignFields :: Text -> FieldDef - -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) - toForeignFields fieldText pfd = - case chktypes fd haskellField pfd of - Just err -> error err - Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) - where - fd = getFd ent haskellField - - haskellField = FieldNameHS fieldText - (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - - chktypes ffld _fkey pfld = - if fieldType ffld == fieldType pfld then Nothing - else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - - getFd :: EntityDef -> FieldNameHS -> FieldDef - getFd entity t = go (keyAndEntityFields entity) - where - go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity) - ++ " unknown column: " ++ show t - go (f:fs) - | fieldHaskell f == t = f - | otherwise = go fs - - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef - - -data UnboundEntityDef = UnboundEntityDef - { _unboundForeignDefs :: [UnboundForeignDef] - , unboundEntityDef :: EntityDef - } - -overUnboundEntityDef - :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overUnboundEntityDef f ubed = - ubed { unboundEntityDef = f (unboundEntityDef ubed) } - -lookupKeyVal :: Text -> [Text] -> Maybe Text -lookupKeyVal key = lookupPrefix $ key `mappend` "=" - -lookupPrefix :: Text -> [Text] -> Maybe Text -lookupPrefix prefix = msum . map (T.stripPrefix prefix) - --- | Construct an entity definition. -mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines - -> UnboundEntityDef -mkEntityDef ps name entattribs lines = - UnboundEntityDef foreigns $ - EntityDef - { entityHaskell = EntityNameHS name' - , entityDB = EntityNameDB $ getDbName ps name' entattribs - -- idField is the user-specified Id - -- otherwise useAutoIdField - -- but, adjust it if the user specified a Primary - , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entattribs - , entityFields = cols - , entityUniques = uniqs - , entityForeigns = [] - , entityDerives = concat $ mapMaybe takeDerives textAttribs - , entityExtra = extras - , entitySum = isSum - , entityComments = Nothing - } - where - entName = EntityNameHS name' - (isSum, name') = - case T.uncons name of - Just ('+', x) -> (True, x) - _ -> (False, name) - (attribs, extras) = splitExtras lines - - textAttribs :: [[Text]] - textAttribs = - fmap tokenText <$> attribs - - attribPrefix = flip lookupKeyVal entattribs - idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" - | otherwise = Nothing - - (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr - squish xs m = xs `mappend` maybeToList m - in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs - - cols :: [FieldDef] - cols = reverse . fst . foldr k ([], []) $ reverse attribs - - k x (!acc, !comments) = - case listToMaybe x of - Just (DocComment comment) -> - (acc, comment : comments) - _ -> - case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of - Just sm -> - (sm : acc, []) - Nothing -> - (acc, []) - - autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType - idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite - - setComposite Nothing fd = fd - setComposite (Just c) fd = fd - { fieldReference = CompositeRef c - } - -setFieldComments :: [Text] -> FieldDef -> FieldDef -setFieldComments xs fld = - case xs of - [] -> fld - _ -> fld { fieldComments = Just (T.unlines xs) } - -just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x -just1 (Just x) (Just y) = error $ "expected only one of: " - `mappend` show x `mappend` " " `mappend` show y -just1 x y = x `mplus` y - -mkAutoIdField :: PersistSettings -> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef -mkAutoIdField ps entName idName idSqlType = - FieldDef - { fieldHaskell = FieldNameHS "Id" - -- this should be modeled as a Maybe - -- but that sucks for non-ID field - -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName - , fieldSqlType = idSqlType - -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - , fieldCascade = noCascade - , fieldGenerated = Nothing - } - -defaultReferenceTypeCon :: FieldType -defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" - -keyConName :: Text -> Text -keyConName entName = entName `mappend` "Id" - -splitExtras - :: [Line] - -> ( [[Token]] - , M.Map Text [ExtraLine] - ) -splitExtras lns = - case lns of - [] -> ([], M.empty) - (line : rest) -> - case line of - Line indent [Token name] - | isCapitalizedText name -> - let (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = splitExtras rest' - in (x, M.insert name (map lineText children) y) - Line _ ts -> - let (x, y) = splitExtras rest - in (ts:x, y) - -isCapitalizedText :: Text -> Bool -isCapitalizedText t = - not (T.null t) && isUpper (T.head t) - -takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef -takeColsEx = - takeCols - (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) - -takeCols - :: (Text -> String -> Maybe FieldDef) - -> PersistSettings - -> [Text] - -> Maybe FieldDef -takeCols _ _ ("deriving":_) = Nothing -takeCols onErr ps (n':typ:rest') - | not (T.null n) && isLower (T.head n) = - case parseFieldType typ of - Left err -> onErr typ err - Right ft -> Just FieldDef - { fieldHaskell = FieldNameHS n - , fieldDB = FieldNameDB $ getDbName ps n attrs_ - , fieldType = ft - , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = fieldAttrs_ - , fieldStrict = fromMaybe (psStrictFields ps) mstrict - , fieldReference = NoReference - , fieldComments = Nothing - , fieldCascade = cascade_ - , fieldGenerated = generated_ - } - where - fieldAttrs_ = parseFieldAttrs attrs_ - generated_ = parseGenerated attrs_ - (cascade_, attrs_) = parseCascade rest' - (mstrict, n) - | Just x <- T.stripPrefix "!" n' = (Just True, x) - | Just x <- T.stripPrefix "~" n' = (Just False, x) - | otherwise = (Nothing, n') - -takeCols _ _ _ = Nothing - -parseGenerated :: [Text] -> Maybe Text -parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing - -getDbName :: PersistSettings -> Text -> [Text] -> Text -getDbName ps n [] = psToDBName ps n -getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a - -takeConstraint :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' - where - takeConstraint' - | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) - | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) - | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) - | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint -takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) - --- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. --- need to re-work takeCols function -takeId :: PersistSettings -> Text -> [Text] -> FieldDef -takeId ps tableName (n:rest) = - setFieldDef - $ fromMaybe (error "takeId: impossible!") - $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) - where - field = case T.uncons n of - Nothing -> error "takeId: empty field" - Just (f, ield) -> toLower f `T.cons` ield - addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) - setFieldDef fd = fd - { fieldReference = - ForeignRef (EntityNameHS tableName) $ - if fieldType fd == FTTypeCon Nothing keyCon - then defaultReferenceTypeCon - else fieldType fd - } - keyCon = keyConName tableName - -- this will be ignored if there is already an existing sql= - -- TODO: I think there is a ! ignore syntax that would screw this up - -- setIdName = ["sql=" `mappend` psIdName ps] -takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName - - -takeComposite - :: [FieldDef] - -> [Text] - -> CompositeDef -takeComposite fields pkcols = - CompositeDef (map (getDef fields) pkcols) attrs - where - (_, attrs) = break ("!" `T.isPrefixOf`) pkcols - getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t - getDef (d:ds) t - | fieldHaskell d == FieldNameHS t = - if nullable (fieldAttrs d) /= NotNullable - then error $ "primary key column cannot be nullable: " ++ show t ++ show fields - else d - | otherwise = getDef ds t - --- Unique UppercaseConstraintName list of lowercasefields terminated --- by ! or sql= such that a unique constraint can look like: --- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` --- Here using sql= sets the name of the constraint. -takeUniq :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UniqueDef -takeUniq ps tableName defs (n:rest) - | isCapitalizedText n - = UniqueDef - (ConstraintNameHS n) - dbName - (map (FieldNameHS &&& getDBName defs) fields) - attrs - where - isAttr a = - "!" `T.isPrefixOf` a - isSqlName a = - "sql=" `T.isPrefixOf` a - isNonField a = - isAttr a - || isSqlName a - (fields, nonFields) = - break isNonField rest - attrs = filter isAttr nonFields - usualDbName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - sqlName :: Maybe ConstraintNameDB - sqlName = - case find isSqlName nonFields of - Nothing -> - Nothing - (Just t) -> - case drop 1 $ T.splitOn "=" t of - (x : _) -> Just (ConstraintNameDB x) - _ -> Nothing - dbName = fromMaybe usualDbName sqlName - getDBName [] t = - error $ "Unknown column in unique constraint: " ++ show t - ++ " " ++ show defs ++ show n ++ " " ++ show attrs - getDBName (d:ds) t - | fieldHaskell d == FieldNameHS t = fieldDB d - | otherwise = getDBName ds t -takeUniq _ tableName _ xs = - error $ "invalid unique constraint on table[" - ++ show tableName - ++ "] expecting an uppercase constraint name xs=" - ++ show xs - -data UnboundForeignDef = UnboundForeignDef - { _unboundForeignFields :: [Text] -- ^ fields in the parent entity - , _unboundParentFields :: [Text] -- ^ fields in parent entity - , _unboundForeignDef :: ForeignDef - } - -takeForeign - :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UnboundForeignDef -takeForeign ps tableName _defs = takeRefTable - where - errorPrefix :: String - errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " - - takeRefTable :: [Text] -> UnboundForeignDef - takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" - takeRefTable (refTableName:restLine) = go restLine Nothing Nothing - where - go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fFields pFields $ ForeignDef - { foreignRefTableHaskell = - EntityNameHS refTableName - , foreignRefTableDBName = - EntityNameDB $ psToDBName ps refTableName - , foreignConstraintNameHaskell = - ConstraintNameHS n - , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` n) - , foreignFieldCascade = FieldCascade - { fcOnDelete = onDelete - , fcOnUpdate = onUpdate - } - , foreignFields = - [] - , foreignAttrs = - attrs - , foreignNullable = - False - , foreignToPrimary = - null pFields - } - where - (fields,attrs) = break ("!" `T.isPrefixOf`) rest - (fFields, pFields) = case break (== "References") fields of - (ffs, []) -> (ffs, []) - (ffs, _ : pfs) -> case (length ffs, length pfs) of - (flen, plen) | flen == plen -> (ffs, pfs) - (flen, plen) -> error $ errorPrefix ++ concat - [ "Found ", show flen, " foreign fields but " - , show plen, " parent fields" ] - - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = - case onDelete' of - Nothing -> - go rest (Just cascadingAction) onUpdate - Just _ -> - error $ errorPrefix ++ "found more than one OnDelete actions" - - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = - case onUpdate' of - Nothing -> - go rest onDelete (Just cascadingAction) - Just _ -> - error $ errorPrefix ++ "found more than one OnUpdate actions" - - go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs - -data CascadePrefix = CascadeUpdate | CascadeDelete - -parseCascade :: [Text] -> (FieldCascade, [Text]) -parseCascade allTokens = - go [] Nothing Nothing allTokens - where - go acc mupd mdel tokens_ = - case tokens_ of - [] -> - ( FieldCascade - { fcOnDelete = mdel - , fcOnUpdate = mupd - } - , acc - ) - this : rest -> - case parseCascadeAction CascadeUpdate this of - Just cascUpd -> - case mupd of - Nothing -> - go acc (Just cascUpd) mdel rest - Just _ -> - nope "found more than one OnUpdate action" - Nothing -> - case parseCascadeAction CascadeDelete this of - Just cascDel -> - case mdel of - Nothing -> - go acc mupd (Just cascDel) rest - Just _ -> - nope "found more than one OnDelete action: " - Nothing -> - go (this : acc) mupd mdel rest - nope msg = - error $ msg <> ", tokens: " <> show allTokens - -parseCascadeAction - :: CascadePrefix - -> Text - -> Maybe CascadeAction -parseCascadeAction prfx text = do - cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text - case readEither (T.unpack cascadeStr) of - Right a -> - Just a - Left _ -> - Nothing - where - toPrefix cp = - case cp of - CascadeUpdate -> "Update" - CascadeDelete -> "Delete" - -takeDerives :: [Text] -> Maybe [Text] -takeDerives ("deriving":rest) = Just rest -takeDerives _ = Nothing - -nullable :: [FieldAttr] -> IsNullable -nullable s - | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr - | FieldAttrNullable `elem` s = Nullable ByNullableAttr - | otherwise = NotNullable +import Database.Persist.Quasi.Internal diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index a0e802507..16cfae28a 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -28,7 +28,7 @@ import Control.Monad.Trans.Reader (ReaderT, ask) import Database.Persist import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) +import Database.Persist.Sql.Types.Internal (SqlBackend(..), IsolationLevel (..)) import Database.Persist.Sql.Class import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) import Database.Persist.Sql.Raw diff --git a/persistent/Database/Persist/Sql/Migration.hs b/persistent/Database/Persist/Sql/Migration.hs index f4846f309..6e2ecd090 100644 --- a/persistent/Database/Persist/Sql/Migration.hs +++ b/persistent/Database/Persist/Sql/Migration.hs @@ -31,6 +31,7 @@ import System.IO.Silently (hSilence) import GHC.Stack import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw import Database.Persist.Types import Database.Persist.Sql.Orphan.PersistStore() diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 3dc784292..c573f0287 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -26,7 +26,7 @@ import Database.Persist hiding (updateField) import Database.Persist.Sql.Util ( entityColumnNames, parseEntityValues, isIdField, updatePersistValue , mkUpdateText, commaSeparated, dbIdColumns) -import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) @@ -433,4 +433,4 @@ decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = [ sql , lim , off - ] \ No newline at end of file + ] diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index e3420c255..906e2972b 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -43,6 +43,7 @@ import Database.Persist.Class () import Database.Persist.Sql.Class (PersistFieldSql) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Util ( dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames , updatePersistValue, mkUpdateText, commaSeparated, mkInsertValues) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs index f9a0c62d3..3d4338727 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues) -import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index b3bd2b72e..e5340de47 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -16,6 +16,7 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Class rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index 2bc79b3ea..d66c72a9c 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel) +import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw -- | Get a connection from the pool, run the given action, and then return the diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index 9d5e870d7..fd0a4ddda 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -1,6 +1,6 @@ module Database.Persist.Sql.Types ( module Database.Persist.Sql.Types - , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..) + , SqlBackend, SqlReadBackend (..), SqlWriteBackend (..) , Statement (..), LogFunc, InsertSqlResult (..) , readToUnknown, readToWrite, writeToUnknown , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 980cc6e08..2ef1eaeb5 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -34,7 +34,8 @@ import Database.Persist ( , FieldDef(..) ) -import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeFieldName) +import Database.Persist.Sql.Types (Sql) +import Database.Persist.Sql.Types.Internal (SqlBackend, connEscapeFieldName) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn = diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 26f1c9d27..b4f53090d 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -49,6 +49,7 @@ library exposed-modules: Database.Persist Database.Persist.Quasi + Database.Persist.Quasi.Internal Database.Persist.TH Database.Persist.Types @@ -57,7 +58,6 @@ library Database.Persist.Sql.Util Database.Persist.Sql.Types.Internal - other-modules: Database.Persist.Types.Base Database.Persist.Class.DeleteCascade Database.Persist.Class.PersistEntity Database.Persist.Class.PersistQuery @@ -66,6 +66,8 @@ library Database.Persist.Class.PersistField Database.Persist.Class.PersistStore + other-modules: Database.Persist.Types.Base + Database.Persist.Sql.Migration Database.Persist.Sql.Internal Database.Persist.Sql.Types @@ -87,7 +89,7 @@ library test-suite test type: exitcode-stdio-1.0 - main-is: test/main.hs + main-is: main.hs build-depends: base >= 4.9 && < 5 @@ -100,6 +102,7 @@ test-suite test , hspec >= 2.4 , http-api-data , path-pieces + , persistent , scientific , shakespeare , text @@ -124,7 +127,6 @@ test-suite test , th-lift-instances hs-source-dirs: - ./ test/ cpp-options: -DTEST @@ -134,11 +136,11 @@ test-suite test , TypeFamilies other-modules: - Database.Persist.Class.PersistEntity - Database.Persist.Class.PersistField - Database.Persist.Quasi - Database.Persist.Types - Database.Persist.Types.Base + -- Database.Persist.Class.PersistEntity + -- Database.Persist.Class.PersistField + -- Database.Persist.Quasi + -- Database.Persist.Types + -- Database.Persist.Types.Base Database.Persist.THSpec TemplateTestImports Database.Persist.TH.SharedPrimaryKeySpec From ae47d21aad8d35845dac3e9fef1c2b171000a443 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 5 Apr 2021 17:54:52 -0600 Subject: [PATCH 02/14] abstractification --- persistent/Database/Persist/Quasi/Internal.hs | 847 ++++++++++++++++++ 1 file changed, 847 insertions(+) create mode 100644 persistent/Database/Persist/Quasi/Internal.hs diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs new file mode 100644 index 000000000..0314a09a7 --- /dev/null +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -0,0 +1,847 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.Persist.Quasi.Internal + ( parse + , PersistSettings (..) + , upperCaseSettings + , lowerCaseSettings + , nullable + , Token (..) + , Line' (..) + , preparse + , parseLine + , parseFieldType + , associateLines + , skipEmpty + , LinesWithComments(..) + , splitExtras + , takeColsEx + ) where + +import Prelude hiding (lines) + +import Control.Applicative ( Alternative((<|>)) ) +import Control.Arrow ((&&&)) +import Control.Monad (msum, mplus) +import Data.Char ( isLower, isSpace, isUpper, toLower ) +import Data.List (find, foldl') +import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) +import Data.Monoid (mappend) +#if !MIN_VERSION_base(4,11,0) +-- This can be removed when GHC < 8.2.2 isn't supported anymore +import Data.Semigroup ((<>)) +#endif +import Data.Text (Text) +import qualified Data.Text as T +import Database.Persist.Types +import Text.Read (readEither) + +data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show + +parseFieldType :: Text -> Either String FieldType +parseFieldType t0 = + case parseApplyFT t0 of + PSSuccess ft t' + | T.all isSpace t' -> Right ft + PSFail err -> Left $ "PSFail " ++ err + other -> Left $ show other + where + parseApplyFT t = + case goMany id t of + PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' + PSSuccess [] _ -> PSFail "empty" + PSFail err -> PSFail err + PSDone -> PSDone + + parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType + parseEnclosed end ftMod t = + let (a, b) = T.break (== end) t + in case parseApplyFT a of + PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of + ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') + (x, y) -> PSFail $ show (b, x, y) + x -> PSFail $ show x + + parse1 t = + case T.uncons t of + Nothing -> PSDone + Just (c, t') + | isSpace c -> parse1 $ T.dropWhile isSpace t' + | c == '(' -> parseEnclosed ')' id t' + | c == '[' -> parseEnclosed ']' FTList t' + | isUpper c -> + let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t + in PSSuccess (getCon a) b + | otherwise -> PSFail $ show (c, t') + getCon t = + case T.breakOnEnd "." t of + (_, "") -> FTTypeCon Nothing t + ("", _) -> FTTypeCon Nothing t + (a, b) -> FTTypeCon (Just $ T.init a) b + goMany front t = + case parse1 t of + PSSuccess x t' -> goMany (front . (x:)) t' + PSFail err -> PSFail err + PSDone -> PSSuccess (front []) t + -- _ -> + +data PersistSettings = PersistSettings + { psToDBName :: !(Text -> Text) + , psStrictFields :: !Bool + -- ^ Whether fields are by default strict. Default value: @True@. + -- + -- @since 1.2 + , psIdName :: !Text + -- ^ The name of the id column. Default value: @id@ + -- The name of the id column can also be changed on a per-model basis + -- + -- + -- @since 2.0 + } + +defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings +defaultPersistSettings = PersistSettings + { psToDBName = id + , psStrictFields = True + , psIdName = "id" + } + +upperCaseSettings = defaultPersistSettings + +lowerCaseSettings = defaultPersistSettings + { psToDBName = + let go c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c + in T.dropWhile (== '_') . T.concatMap go + } + +-- | Parses a quasi-quoted syntax into a list of entity definitions. +parse :: PersistSettings -> Text -> [EntityDef] +parse ps = maybe [] (parseLines ps) . preparse + +preparse :: Text -> Maybe (NonEmpty Line) +preparse txt = do + lns <- NEL.nonEmpty (T.lines txt) + NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) + +-- TODO: refactor to return (Line' NonEmpty), made possible by +-- https://github.com/yesodweb/persistent/pull/1206 but left out +-- in order to minimize the diff +parseLine :: Text -> Maybe Line +parseLine txt = + case tokenize txt of + [] -> + Nothing + toks -> + pure $ Line (parseIndentationAmount txt) toks + +-- | A token used by the parser. +data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. + | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. + deriving (Show, Eq) + +tokenText :: Token -> Text +tokenText tok = + case tok of + Token t -> t + DocComment t -> "-- | " <> t + +parseIndentationAmount :: Text -> Int +parseIndentationAmount txt = + let (spaces, _) = T.span isSpace txt + in T.length spaces + +-- | Tokenize a string. +tokenize :: Text -> [Token] +tokenize t + | T.null t = [] + | Just txt <- T.stripPrefix "-- | " t = [DocComment txt] + | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. + | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) + | T.head t == '"' = quotes (T.tail t) id + | T.head t == '(' = parens 1 (T.tail t) id + | isSpace (T.head t) = + tokenize (T.dropWhile isSpace t) + + -- support mid-token quotes and parens + | Just (beforeEquals, afterEquals) <- findMidToken t + , not (T.any isSpace beforeEquals) + , Token next : rest <- tokenize afterEquals = + Token (T.concat [beforeEquals, "=", next]) : rest + + | otherwise = + let (token, rest) = T.break isSpace t + in Token token : tokenize rest + where + findMidToken t' = + case T.break (== '=') t' of + (x, T.drop 1 -> y) + | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) + _ -> Nothing + + quotes t' front + | T.null t' = error $ T.unpack $ T.concat $ + "Unterminated quoted string starting with " : front [] + | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') + | T.head t' == '\\' && T.length t' > 1 = + quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) + | otherwise = + let (x, y) = T.break (`elem` ['\\','\"']) t' + in quotes y (front . (x:)) + parens count t' front + | T.null t' = error $ T.unpack $ T.concat $ + "Unterminated parens string starting with " : front [] + | T.head t' == ')' = + if count == (1 :: Int) + then Token (T.concat $ front []) : tokenize (T.tail t') + else parens (count - 1) (T.tail t') (front . (")":)) + | T.head t' == '(' = + parens (count + 1) (T.tail t') (front . ("(":)) + | T.head t' == '\\' && T.length t' > 1 = + parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) + | otherwise = + let (x, y) = T.break (`elem` ['\\','(',')']) t' + in parens count y (front . (x:)) + +-- | A line. We don't care about spaces in the middle of the +-- line. Also, we don't care about the amount of indentation. +data Line' f + = Line + { lineIndent :: Int + , tokens :: f Token + } + +deriving instance Show (f Token) => Show (Line' f) +deriving instance Eq (f Token) => Eq (Line' f) + +mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g +mapLine k (Line i t) = Line i (k t) + +traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) +traverseLine k (Line i xs) = Line i <$> k xs + +lineText :: Functor f => Line' f -> f Text +lineText = fmap tokenText . tokens + +type Line = Line' [] + +lowestIndent + :: Functor f + => Foldable f + => Functor g + => f (Line' g) + -> Int +lowestIndent = minimum . fmap lineIndent + +-- | Divide lines into blocks and make entity definitions. +parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] +parseLines ps = + fixForeignKeysAll . map mk . associateLines . skipEmpty + where + mk :: LinesWithComments -> UnboundEntityDef + mk lwc = + let ln :| rest = lwcLines lwc + (name :| entAttribs) = lineText ln + in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) + +isDocComment :: Token -> Maybe Text +isDocComment tok = + case tok of + DocComment txt -> Just txt + _ -> Nothing + +data LinesWithComments = LinesWithComments + { lwcLines :: NonEmpty (Line' NonEmpty) + , lwcComments :: [Text] + } deriving (Eq, Show) + +-- TODO: drop this and use <> when 8.2 isn't supported anymore so the +-- monoid/semigroup nonsense isn't annoying +appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments +appendLwc a b = + LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) + +newLine :: Line' NonEmpty -> LinesWithComments +newLine l = LinesWithComments (pure l) [] + +firstLine :: LinesWithComments -> Line' NonEmpty +firstLine = NEL.head . lwcLines + +consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments +consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } + +consComment :: Text -> LinesWithComments -> LinesWithComments +consComment l lwc = lwc { lwcComments = l : lwcComments lwc } + +associateLines :: [Line' NonEmpty] -> [LinesWithComments] +associateLines lines = + foldr combine [] $ + foldr toLinesWithComments [] lines + where + toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments] + toLinesWithComments line linesWithComments = + case linesWithComments of + [] -> + [newLine line] + (lwc : lwcs) -> + case isDocComment (NEL.head (tokens line)) of + Just comment + | lineIndent line == lowestIndent lines -> + consComment comment lwc : lwcs + _ -> + if lineIndent line <= lineIndent (firstLine lwc) + && lineIndent (firstLine lwc) /= lowestIndent lines + then + consLine line lwc : lwcs + else + newLine line : lwc : lwcs + + combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] + combine lwc [] = + [lwc] + combine lwc (lwc' : lwcs) = + let minIndent = minimumIndentOf lwc + otherIndent = minimumIndentOf lwc' + in + if minIndent < otherIndent then + appendLwc lwc lwc' : lwcs + else + lwc : lwc' : lwcs + + + minimumIndentOf = lowestIndent . lwcLines + +skipEmpty :: NonEmpty (Line' []) -> [Line' NonEmpty] +skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) . NEL.toList + +setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef +setComments [] = id +setComments comments = + overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) + +fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] +fixForeignKeysAll unEnts = map fixForeignKeys unEnts + where + ents = map unboundEntityDef unEnts + entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents + + fixForeignKeys :: UnboundEntityDef -> EntityDef + fixForeignKeys (UnboundEntityDef foreigns ent) = + ent { entityForeigns = map (fixForeignKey ent) foreigns } + + -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns + fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef + fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = + case mfdefs of + Just fdefs -> + if length foreignFieldTexts /= length fdefs + then + lengthError fdefs + else + let + fds_ffs = + zipWith toForeignFields + foreignFieldTexts + fdefs + dbname = + unEntityNameDB (entityDB pent) + oldDbName = + unEntityNameDB (foreignRefTableDBName fdef) + in fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + EntityNameDB dbname + , foreignConstraintNameDBName = + ConstraintNameDB + . T.replace oldDbName dbname . unConstraintNameDB + $ foreignConstraintNameDBName fdef + } + Nothing -> + error $ "no primary key found fdef="++show fdef++ " ent="++show ent + where + pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + mfdefs = case parentFieldTexts of + [] -> entitiesPrimary pent + _ -> Just $ map (getFd pent . FieldNameHS) parentFieldTexts + + setNull :: [FieldDef] -> Bool + setNull [] = error "setNull: impossible!" + setNull (fd:fds) = let nullSetting = isNull fd in + if all ((nullSetting ==) . isNull) fds then nullSetting + else error $ "foreign key columns must all be nullable or non-nullable" + ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds)) + isNull = (NotNullable /=) . nullable . fieldAttrs + + toForeignFields :: Text -> FieldDef + -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) + toForeignFields fieldText pfd = + case chktypes fd haskellField pfd of + Just err -> error err + Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) + where + fd = getFd ent haskellField + + haskellField = FieldNameHS fieldText + (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) + + chktypes ffld _fkey pfld = + if fieldType ffld == fieldType pfld then Nothing + else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) + + getFd :: EntityDef -> FieldNameHS -> FieldDef + getFd entity t = go (keyAndEntityFields entity) + where + go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity) + ++ " unknown column: " ++ show t + go (f:fs) + | fieldHaskell f == t = f + | otherwise = go fs + + lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef + + +data UnboundEntityDef = UnboundEntityDef + { _unboundForeignDefs :: [UnboundForeignDef] + , unboundEntityDef :: EntityDef + } + +overUnboundEntityDef + :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef +overUnboundEntityDef f ubed = + ubed { unboundEntityDef = f (unboundEntityDef ubed) } + +lookupKeyVal :: Text -> [Text] -> Maybe Text +lookupKeyVal key = lookupPrefix $ key `mappend` "=" + +lookupPrefix :: Text -> [Text] -> Maybe Text +lookupPrefix prefix = msum . map (T.stripPrefix prefix) + +-- | Construct an entity definition. +mkEntityDef :: PersistSettings + -> Text -- ^ name + -> [Attr] -- ^ entity attributes + -> [Line] -- ^ indented lines + -> UnboundEntityDef +mkEntityDef ps name entattribs lines = + UnboundEntityDef foreigns $ + EntityDef + { entityHaskell = EntityNameHS name' + , entityDB = EntityNameDB $ getDbName ps name' entattribs + -- idField is the user-specified Id + -- otherwise useAutoIdField + -- but, adjust it if the user specified a Primary + , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField + , entityAttrs = entattribs + , entityFields = cols + , entityUniques = uniqs + , entityForeigns = [] + , entityDerives = concat $ mapMaybe takeDerives textAttribs + , entityExtra = extras + , entitySum = isSum + , entityComments = Nothing + } + where + entName = EntityNameHS name' + (isSum, name') = + case T.uncons name of + Just ('+', x) -> (True, x) + _ -> (False, name) + (attribs, extras) = splitExtras lines + + textAttribs :: [[Text]] + textAttribs = + fmap tokenText <$> attribs + + attribPrefix = flip lookupKeyVal entattribs + idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" + | otherwise = Nothing + + (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> + let (i, p, u, f) = takeConstraint ps name' cols attr + squish xs m = xs `mappend` maybeToList m + in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs + + cols :: [FieldDef] + cols = reverse . fst . foldr k ([], []) $ reverse attribs + + k x (!acc, !comments) = + case listToMaybe x of + Just (DocComment comment) -> + (acc, comment : comments) + _ -> + case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of + Just sm -> + (sm : acc, []) + Nothing -> + (acc, []) + + autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType + idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite + + setComposite Nothing fd = fd + setComposite (Just c) fd = fd + { fieldReference = CompositeRef c + } + +setFieldComments :: [Text] -> FieldDef -> FieldDef +setFieldComments xs fld = + case xs of + [] -> fld + _ -> fld { fieldComments = Just (T.unlines xs) } + +just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x +just1 (Just x) (Just y) = error $ "expected only one of: " + `mappend` show x `mappend` " " `mappend` show y +just1 x y = x `mplus` y + +mkAutoIdField :: PersistSettings -> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef +mkAutoIdField ps entName idName idSqlType = + FieldDef + { fieldHaskell = FieldNameHS "Id" + -- this should be modeled as a Maybe + -- but that sucks for non-ID field + -- TODO: use a sumtype FieldDef | IdFieldDef + , fieldDB = fromMaybe (FieldNameDB $ psIdName ps) idName + , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName + , fieldSqlType = idSqlType + -- the primary field is actually a reference to the entity + , fieldReference = ForeignRef entName defaultReferenceTypeCon + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + , fieldGenerated = Nothing + } + +defaultReferenceTypeCon :: FieldType +defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" + +keyConName :: Text -> Text +keyConName entName = entName `mappend` "Id" + +splitExtras + :: [Line] + -> ( [[Token]] + , M.Map Text [ExtraLine] + ) +splitExtras lns = + case lns of + [] -> ([], M.empty) + (line : rest) -> + case line of + Line indent [Token name] + | isCapitalizedText name -> + let (children, rest') = span ((> indent) . lineIndent) rest + (x, y) = splitExtras rest' + in (x, M.insert name (map lineText children) y) + Line _ ts -> + let (x, y) = splitExtras rest + in (ts:x, y) + +isCapitalizedText :: Text -> Bool +isCapitalizedText t = + not (T.null t) && isUpper (T.head t) + +takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef +takeColsEx = + takeCols + (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) + +takeCols + :: (Text -> String -> Maybe FieldDef) + -> PersistSettings + -> [Text] + -> Maybe FieldDef +takeCols _ _ ("deriving":_) = Nothing +takeCols onErr ps (n':typ:rest') + | not (T.null n) && isLower (T.head n) = + case parseFieldType typ of + Left err -> onErr typ err + Right ft -> Just FieldDef + { fieldHaskell = FieldNameHS n + , fieldDB = FieldNameDB $ getDbName ps n attrs_ + , fieldType = ft + , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n + , fieldAttrs = fieldAttrs_ + , fieldStrict = fromMaybe (psStrictFields ps) mstrict + , fieldReference = NoReference + , fieldComments = Nothing + , fieldCascade = cascade_ + , fieldGenerated = generated_ + } + where + fieldAttrs_ = parseFieldAttrs attrs_ + generated_ = parseGenerated attrs_ + (cascade_, attrs_) = parseCascade rest' + (mstrict, n) + | Just x <- T.stripPrefix "!" n' = (Just True, x) + | Just x <- T.stripPrefix "~" n' = (Just False, x) + | otherwise = (Nothing, n') + +takeCols _ _ _ = Nothing + +parseGenerated :: [Text] -> Maybe Text +parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing + +getDbName :: PersistSettings -> Text -> [Text] -> Text +getDbName ps n [] = psToDBName ps n +getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a + +takeConstraint :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) +takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' + where + takeConstraint' + | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) + | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) + | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) + | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) + | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint +takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) + +-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. +-- need to re-work takeCols function +takeId :: PersistSettings -> Text -> [Text] -> FieldDef +takeId ps tableName (n:rest) = + setFieldDef + $ fromMaybe (error "takeId: impossible!") + $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) + where + field = case T.uncons n of + Nothing -> error "takeId: empty field" + Just (f, ield) -> toLower f `T.cons` ield + addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) + setFieldDef fd = fd + { fieldReference = + ForeignRef (EntityNameHS tableName) $ + if fieldType fd == FTTypeCon Nothing keyCon + then defaultReferenceTypeCon + else fieldType fd + } + keyCon = keyConName tableName + -- this will be ignored if there is already an existing sql= + -- TODO: I think there is a ! ignore syntax that would screw this up + -- setIdName = ["sql=" `mappend` psIdName ps] +takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName + + +takeComposite + :: [FieldDef] + -> [Text] + -> CompositeDef +takeComposite fields pkcols = + CompositeDef (map (getDef fields) pkcols) attrs + where + (_, attrs) = break ("!" `T.isPrefixOf`) pkcols + getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t + getDef (d:ds) t + | fieldHaskell d == FieldNameHS t = + if nullable (fieldAttrs d) /= NotNullable + then error $ "primary key column cannot be nullable: " ++ show t ++ show fields + else d + | otherwise = getDef ds t + +-- Unique UppercaseConstraintName list of lowercasefields terminated +-- by ! or sql= such that a unique constraint can look like: +-- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` +-- Here using sql= sets the name of the constraint. +takeUniq :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UniqueDef +takeUniq ps tableName defs (n:rest) + | isCapitalizedText n + = UniqueDef + (ConstraintNameHS n) + dbName + (map (FieldNameHS &&& getDBName defs) fields) + attrs + where + isAttr a = + "!" `T.isPrefixOf` a + isSqlName a = + "sql=" `T.isPrefixOf` a + isNonField a = + isAttr a + || isSqlName a + (fields, nonFields) = + break isNonField rest + attrs = filter isAttr nonFields + usualDbName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + sqlName :: Maybe ConstraintNameDB + sqlName = + case find isSqlName nonFields of + Nothing -> + Nothing + (Just t) -> + case drop 1 $ T.splitOn "=" t of + (x : _) -> Just (ConstraintNameDB x) + _ -> Nothing + dbName = fromMaybe usualDbName sqlName + getDBName [] t = + error $ "Unknown column in unique constraint: " ++ show t + ++ " " ++ show defs ++ show n ++ " " ++ show attrs + getDBName (d:ds) t + | fieldHaskell d == FieldNameHS t = fieldDB d + | otherwise = getDBName ds t +takeUniq _ tableName _ xs = + error $ "invalid unique constraint on table[" + ++ show tableName + ++ "] expecting an uppercase constraint name xs=" + ++ show xs + +data UnboundForeignDef = UnboundForeignDef + { _unboundForeignFields :: [Text] -- ^ fields in the parent entity + , _unboundParentFields :: [Text] -- ^ fields in parent entity + , _unboundForeignDef :: ForeignDef + } + +takeForeign + :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UnboundForeignDef +takeForeign ps tableName _defs = takeRefTable + where + errorPrefix :: String + errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " + + takeRefTable :: [Text] -> UnboundForeignDef + takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" + takeRefTable (refTableName:restLine) = go restLine Nothing Nothing + where + go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) + = UnboundForeignDef fFields pFields $ ForeignDef + { foreignRefTableHaskell = + EntityNameHS refTableName + , foreignRefTableDBName = + EntityNameDB $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + ConstraintNameHS n + , foreignConstraintNameDBName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + , foreignFieldCascade = FieldCascade + { fcOnDelete = onDelete + , fcOnUpdate = onUpdate + } + , foreignFields = + [] + , foreignAttrs = + attrs + , foreignNullable = + False + , foreignToPrimary = + null pFields + } + where + (fields,attrs) = break ("!" `T.isPrefixOf`) rest + (fFields, pFields) = case break (== "References") fields of + (ffs, []) -> (ffs, []) + (ffs, _ : pfs) -> case (length ffs, length pfs) of + (flen, plen) | flen == plen -> (ffs, pfs) + (flen, plen) -> error $ errorPrefix ++ concat + [ "Found ", show flen, " foreign fields but " + , show plen, " parent fields" ] + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + case onDelete' of + Nothing -> + go rest (Just cascadingAction) onUpdate + Just _ -> + error $ errorPrefix ++ "found more than one OnDelete actions" + + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + case onUpdate' of + Nothing -> + go rest onDelete (Just cascadingAction) + Just _ -> + error $ errorPrefix ++ "found more than one OnUpdate actions" + + go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs + +data CascadePrefix = CascadeUpdate | CascadeDelete + +parseCascade :: [Text] -> (FieldCascade, [Text]) +parseCascade allTokens = + go [] Nothing Nothing allTokens + where + go acc mupd mdel tokens_ = + case tokens_ of + [] -> + ( FieldCascade + { fcOnDelete = mdel + , fcOnUpdate = mupd + } + , acc + ) + this : rest -> + case parseCascadeAction CascadeUpdate this of + Just cascUpd -> + case mupd of + Nothing -> + go acc (Just cascUpd) mdel rest + Just _ -> + nope "found more than one OnUpdate action" + Nothing -> + case parseCascadeAction CascadeDelete this of + Just cascDel -> + case mdel of + Nothing -> + go acc mupd (Just cascDel) rest + Just _ -> + nope "found more than one OnDelete action: " + Nothing -> + go (this : acc) mupd mdel rest + nope msg = + error $ msg <> ", tokens: " <> show allTokens + +parseCascadeAction + :: CascadePrefix + -> Text + -> Maybe CascadeAction +parseCascadeAction prfx text = do + cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text + case readEither (T.unpack cascadeStr) of + Right a -> + Just a + Left _ -> + Nothing + where + toPrefix cp = + case cp of + CascadeUpdate -> "Update" + CascadeDelete -> "Delete" + +takeDerives :: [Text] -> Maybe [Text] +takeDerives ("deriving":rest) = Just rest +takeDerives _ = Nothing + +nullable :: [FieldAttr] -> IsNullable +nullable s + | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr + | FieldAttrNullable `elem` s = Nullable ByNullableAttr + | otherwise = NotNullable From 6185fe182096758f5303f8e4f645edcd274c44d3 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 6 Apr 2021 17:55:46 -0600 Subject: [PATCH 03/14] Internalize SqlBackend --- .../Database/Persist/Postgresql.hs | 73 ++++---- persistent-test/ChangeLog.md | 5 + persistent-test/persistent-test.cabal | 4 +- persistent-test/src/Init.hs | 2 + persistent/Database/Persist/Quasi.hs | 2 - persistent/Database/Persist/Quasi/Internal.hs | 4 + .../Persist/Sql/Orphan/PersistQuery.hs | 2 +- persistent/Database/Persist/Sql/Raw.hs | 5 +- .../Database/Persist/Sql/Types/Internal.hs | 171 +----------------- persistent/Database/Persist/Sql/Util.hs | 2 +- persistent/Database/Persist/SqlBackend.hs | 150 +++++++++++++++ .../Database/Persist/SqlBackend/Internal.hs | 164 +++++++++++++++++ .../SqlBackend/Internal/InsertSqlResult.hs | 9 + .../SqlBackend/Internal/IsolationLevel.hs | 18 ++ .../SqlBackend/Internal/MkSqlBackend.hs | 85 +++++++++ .../Persist/SqlBackend/Internal/Statement.hs | 19 ++ persistent/persistent.cabal | 7 + persistent/test/main.hs | 2 +- 18 files changed, 515 insertions(+), 209 deletions(-) create mode 100644 persistent/Database/Persist/SqlBackend.hs create mode 100644 persistent/Database/Persist/SqlBackend/Internal.hs create mode 100644 persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs create mode 100644 persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs create mode 100644 persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs create mode 100644 persistent/Database/Persist/SqlBackend/Internal/Statement.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 30e56e872..49f635dd6 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -90,6 +90,7 @@ import Data.Time (utc, NominalDiffTime, localTimeToUTC) import System.Environment (getEnvironment) import Database.Persist.Sql +import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection @@ -335,14 +336,15 @@ openSimpleConnWithVersion getVerDouble logFunc conn = do -- and connection. createBackend :: LogFunc -> NonEmpty Word -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend -createBackend logFunc serverVersion smap conn = do - SqlBackend +createBackend logFunc serverVersion smap conn = + maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ + maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ + setConnInsertManySql insertManySql' $ + maybe id setConnRepsertManySql (upsertFunction repsertManySql serverVersion) $ + mkSqlBackend MkSqlBackendArgs { connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = insertSql' - , connInsertManySql = Just insertManySql' - , connUpsertSql = upsertFunction upsertSql' serverVersion - , connPutManySql = upsertFunction putManySql serverVersion , connClose = PG.close conn , connMigrateSql = migrate' , connBegin = \_ mIsolation -> case mIsolation of @@ -361,8 +363,6 @@ createBackend logFunc serverVersion smap conn = do , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" , connLogFunc = logFunc - , connMaxParams = Nothing - , connRepsertManySql = upsertFunction repsertManySql serverVersion } prepare' :: PG.Connection -> Text -> IO Statement @@ -1693,37 +1693,34 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do -- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - }, - connInsertManySql = Nothing, - connInsertSql = undefined, - connUpsertSql = Nothing, - connPutManySql = Nothing, - connStmtMap = smap, - connClose = undefined, - connMigrateSql = mockMigrate, - connBegin = undefined, - connCommit = undefined, - connRollback = undefined, - connEscapeFieldName = escapeF, - connEscapeTableName = escapeE . entityDB, - connEscapeRawName = escape, - connNoLimit = undefined, - connRDBMS = undefined, - connLimitOffset = undefined, - connLogFunc = undefined, - connMaxParams = Nothing, - connRepsertManySql = Nothing - } - result = runReaderT $ runWriterT $ runWriterT mig - resp <- result sqlbackend - mapM_ T.putStrLn $ map snd $ snd resp + smap <- newIORef $ Map.empty + let sqlbackend = + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connInsertSql = undefined + , connStmtMap = smap + , connClose = undefined + , connMigrateSql = mockMigrate + , connBegin = undefined + , connCommit = undefined + , connRollback = undefined + , connEscapeFieldName = escapeF + , connEscapeTableName = escapeE . entityDB + , connEscapeRawName = escape + , connNoLimit = undefined + , connRDBMS = undefined + , connLimitOffset = undefined + , connLogFunc = undefined + } + result = runReaderT $ runWriterT $ runWriterT mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns fields ent n diff --git a/persistent-test/ChangeLog.md b/persistent-test/ChangeLog.md index 11de8b423..6769c383e 100644 --- a/persistent-test/ChangeLog.md +++ b/persistent-test/ChangeLog.md @@ -1,5 +1,10 @@ ## Unreleased changes +## 2.13.0.0 + +* [#]() + * Support `persistent-2.13.0.0` + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 31d232c8c..a03d8ea55 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -1,5 +1,5 @@ name: persistent-test -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -60,7 +60,7 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 2.13 + , persistent >= 2.13 && < 2.14 , aeson >= 1.0 , blaze-html >= 0.9 , bytestring >= 0.10 diff --git a/persistent-test/src/Init.hs b/persistent-test/src/Init.hs index 471be0a49..d5433f075 100644 --- a/persistent-test/src/Init.hs +++ b/persistent-test/src/Init.hs @@ -14,6 +14,7 @@ module Init ( , isTravis , module Database.Persist.Sql + , module Database.Persist.Sql.Types.Internal , persistSettings , MkPersistSettings (..) , BackendKey(..) @@ -91,6 +92,7 @@ import System.IO.Unsafe import Database.Persist import Database.Persist.Sql +import Database.Persist.Sql.Types.Internal import Database.Persist.TH () -- Data types diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index ba0768bc0..76a16632f 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -421,6 +421,4 @@ module Database.Persist.Quasi , nullable ) where -import Prelude hiding (lines) - import Database.Persist.Quasi.Internal diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 0314a09a7..24eb53331 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -6,6 +6,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +-- | This @Internal@ module may have breaking changes that will not be reflected +-- in major version bumps. Please use "Database.Persist.Quasi" instead. +-- +-- @since 2.13.0.0 module Database.Persist.Quasi.Internal ( parse , PersistSettings (..) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index c573f0287..4a1982213 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -26,7 +26,7 @@ import Database.Persist hiding (updateField) import Database.Persist.Sql.Util ( entityColumnNames, parseEntityValues, isIdField, updatePersistValue , mkUpdateText, commaSeparated, dbIdColumns) -import Database.Persist.Sql.Types.Internal +import Database.Persist.Sql.Types.Internal (SqlBackend(..), SqlReadBackend, SqlWriteBackend) import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index e5340de47..8c5eda0de 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -17,6 +17,7 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal +import Database.Persist.SqlBackend.Internal import Database.Persist.Sql.Class rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) @@ -67,8 +68,8 @@ rawExecuteCount sql vals = do return res getStmt - :: (MonadIO m, BackendCompatible SqlBackend backend) - => Text -> ReaderT backend m Statement + :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend) + => Text -> m Statement getStmt sql = do conn <- projectBackend `liftM` ask liftIO $ getStmtConn conn sql diff --git a/persistent/Database/Persist/Sql/Types/Internal.hs b/persistent/Database/Persist/Sql/Types/Internal.hs index 9ba89cde3..34feca045 100644 --- a/persistent/Database/Persist/Sql/Types/Internal.hs +++ b/persistent/Database/Persist/Sql/Types/Internal.hs @@ -1,5 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} +{-# language RecordWildCards #-} +{-# language DuplicateRecordFields #-} + module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..) @@ -26,15 +29,7 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger (LogSource, LogLevel, Loc) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) -import Data.Acquire (Acquire) -import Data.Conduit (ConduitM) -import Data.Int (Int64) -import Data.IORef (IORef) -import Data.Map (Map) import Data.Monoid ((<>)) -import Data.String (IsString) -import Data.Text (Text) -import System.Log.FastLogger (LogStr) import Database.Persist.Class ( HasPersistBackend (..) @@ -45,164 +40,16 @@ import Database.Persist.Class ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.Types - -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -data InsertSqlResult = ISRSingle Text - | ISRInsertGet Text Text - | ISRManyKeys Text [PersistValue] - -data Statement = Statement - { stmtFinalize :: IO () - , stmtReset :: IO () - , stmtExecute :: [PersistValue] -> IO Int64 - , stmtQuery :: forall m. MonadIO m - => [PersistValue] - -> Acquire (ConduitM () [PersistValue] m ()) - } - --- | Please refer to the documentation for the database in question for a full --- overview of the semantics of the varying isloation levels -data IsolationLevel = ReadUncommitted - | ReadCommitted - | RepeatableRead - | Serializable - deriving (Show, Eq, Enum, Ord, Bounded) - -makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s -makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of - ReadUncommitted -> "READ UNCOMMITTED" - ReadCommitted -> "READ COMMITTED" - RepeatableRead -> "REPEATABLE READ" - Serializable -> "SERIALIZABLE" - --- | A 'SqlBackend' represents a handle or connection to a database. It --- contains functions and values that allow databases to have more --- optimized implementations, as well as references that benefit --- performance and sharing. --- --- A 'SqlBackend' is *not* thread-safe. You should not assume that --- a 'SqlBackend' can be shared among threads and run concurrent queries. --- This *will* result in problems. Instead, you should create a @'Pool' --- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in --- multi-threaded applications. --- --- To run actions in the @persistent@ library, you should use the --- 'runSqlConn' function. If you're using a multithreaded application, use --- the 'runSqlPool' function. -data SqlBackend = SqlBackend - { connPrepare :: Text -> IO Statement - -- ^ This function should prepare a 'Statement' in the target database, - -- which should allow for efficient query reuse. - , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult - -- ^ This function generates the SQL and values necessary for - -- performing an insert against the database. - , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) - -- ^ SQL for inserting many rows and returning their primary keys, for - -- backends that support this functionality. If 'Nothing', rows will be - -- inserted one-at-a-time using 'connInsertSql'. - , connUpsertSql :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) - -- ^ Some databases support performing UPSERT _and_ RETURN entity - -- in a single call. - -- - -- This field when set will be used to generate the UPSERT+RETURN sql given - -- * an entity definition - -- * updates to be run on unique key(s) collision - -- - -- When left as 'Nothing', we find the unique key from entity def before - -- * trying to fetch an entity by said key - -- * perform an update when result found, else issue an insert - -- * return new entity from db - -- - -- @since 2.6 - , connPutManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk UPSERT, specifically - -- "insert or replace many records" in a single call. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a PUT MANY sql with placeholders for records - -- - -- When left as 'Nothing', we default to using 'defaultPutMany'. - -- - -- @since 2.8.1 - , connStmtMap :: IORef (Map Text Statement) - -- ^ A reference to the cache of statements. 'Statement's are keyed by - -- the 'Text' queries that generated them. - , connClose :: IO () - -- ^ Close the underlying connection. - , connMigrateSql - :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [(Bool, Text)]) - -- ^ This function returns the migrations required to include the - -- 'EntityDef' parameter in the @['EntityDef']@ database. This might - -- include creating a new table if the entity is not present, or - -- altering an existing table if it is. - , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () - -- ^ A function to begin a transaction for the underlying database. - , connCommit :: (Text -> IO Statement) -> IO () - -- ^ A function to commit a transaction to the underlying database. - , connRollback :: (Text -> IO Statement) -> IO () - -- ^ A function to roll back a transaction on the underlying database. - , connEscapeFieldName :: FieldNameDB -> Text - -- ^ A function to extract and escape the name of the column corresponding - -- to the provided field. - -- - -- @since 2.12.0.0 - , connEscapeTableName :: EntityDef -> Text - -- ^ A function to extract and escape the name of the table corresponding - -- to the provided entity. PostgreSQL uses this to support schemas. - -- - -- @since 2.12.0.0 - , connEscapeRawName :: Text -> Text - -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while - -- PostgreSQL uses quotes, and so on. - -- - -- @since 2.12.0.0 - , connNoLimit :: Text - , connRDBMS :: Text - -- ^ A tag displaying what database the 'SqlBackend' is for. Can be - -- used to differentiate features in downstream libraries for different - -- database backends. - , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text - -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that - -- LIMIT/OFFSET is problematic for performance, and indexed range - -- queries are the superior way to offer pagination. - , connLogFunc :: LogFunc - -- ^ A log function for the 'SqlBackend' to use. - , connMaxParams :: Maybe Int - -- ^ Some databases (probably only Sqlite) have a limit on how - -- many question-mark parameters may be used in a statement - -- - -- @since 2.6.1 - , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk an atomic+bulk INSERT where - -- constraint conflicting entities can replace existing entities. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a INSERT sql with placeholders for primary+record fields - -- - -- When left as 'Nothing', we default to using 'defaultRepsertMany'. - -- - -- @since 2.9.0 - } - -instance HasPersistBackend SqlBackend where - type BaseBackend SqlBackend = SqlBackend - persistBackend = id - -instance IsPersistBackend SqlBackend where - mkPersistBackend = id +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.IsolationLevel -- | An SQL backend which can only handle read queries -- -- The constructor was exposed in 2.10.0. -newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } +newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 2ef1eaeb5..3b059c1f5 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -35,7 +35,7 @@ import Database.Persist ( ) import Database.Persist.Sql.Types (Sql) -import Database.Persist.Sql.Types.Internal (SqlBackend, connEscapeFieldName) +import Database.Persist.SqlBackend.Internal(SqlBackend(..)) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn = diff --git a/persistent/Database/Persist/SqlBackend.hs b/persistent/Database/Persist/SqlBackend.hs new file mode 100644 index 000000000..510d3e3bc --- /dev/null +++ b/persistent/Database/Persist/SqlBackend.hs @@ -0,0 +1,150 @@ +-- | This module contains types and information necessary for a SQL database. +-- Database support libraries, like @persistent-postgresql@, will be responsible +-- for constructing these values. +module Database.Persist.SqlBackend + ( -- * The type and construction + SqlBackend + , mkSqlBackend + , MkSqlBackendArgs(..) + -- * Utilities + + -- $utilities + + , getEscapedFieldName + , getEscapedRawName + , setConnMaxParams + , setConnRepsertManySql + , setConnInsertManySql + , setConnUpsertSql + , setConnPutManySql + ) where + +import Control.Monad.Reader +import Data.Text (Text) +import Database.Persist.Class.PersistStore (BackendCompatible(..)) +import Database.Persist.SqlBackend.Internal +import qualified Database.Persist.SqlBackend.Internal as SqlBackend + (SqlBackend(..)) +import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) +import Database.Persist.Types.Base +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Data.List.NonEmpty (NonEmpty) + +-- $utilities +-- +-- The functions exported here are a bit more general than the record accessors. +-- The easiest way to use them is to provide the 'SqlBackend' directly to the +-- function. However, you can also use them in a 'ReaderT' context, and you can +-- even use them with any @backend@ type tht has a @'BackendCompatible' +-- 'SqlBackend' backend@ instance. + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a 'FieldNameDB'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedFieldName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedFieldName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedFieldName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => FieldNameDB -> m Text +getEscapedFieldName fieldName = do + func <- asks (SqlBackend.connEscapeFieldName . projectBackend) + pure (func fieldName) + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a raw 'Text'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedRawName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedRawName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedRawName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => Text -> m Text +getEscapedRawName name = do + func <- asks (SqlBackend.connEscapeRawName . projectBackend) + pure (func name) + +-- | Set the maximum parameters that may be issued in a given SQL query. This +-- should be used only if the database backend have this limitation. +-- +-- @since 2.13.0.0 +setConnMaxParams + :: Int + -> SqlBackend + -> SqlBackend +setConnMaxParams i sb = + sb { connMaxParams = Just i } + +-- | Set the 'connRepsertManySql' field on the 'SqlBackend'. This should only be +-- set by the database backend library. If this is not set, a slow default will +-- be used. +-- +-- @since 2.13.0.0 +setConnRepsertManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnRepsertManySql mkQuery sb = + sb { connRepsertManySql = Just mkQuery } + +-- | Set the 'connInsertManySql' field on the 'SqlBackend'. This should only be +-- used by the database backend library to provide an efficient implementation +-- of a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnInsertManySql + :: (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -> SqlBackend + -> SqlBackend +setConnInsertManySql mkQuery sb = + sb { connInsertManySql = Just mkQuery } + +-- | Set the 'connUpsertSql' field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnUpsertSql + :: (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -> SqlBackend + -> SqlBackend +setConnUpsertSql mkQuery sb = + sb { connUpsertSql = Just mkQuery } + +-- | Set the 'connPutManySql field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnPutManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnPutManySql mkQuery sb = + sb { connPutManySql = Just mkQuery } diff --git a/persistent/Database/Persist/SqlBackend/Internal.hs b/persistent/Database/Persist/SqlBackend/Internal.hs new file mode 100644 index 000000000..5f888cd56 --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal.hs @@ -0,0 +1,164 @@ +{-# language RecordWildCards #-} +{-# language RankNTypes #-} + +module Database.Persist.SqlBackend.Internal where + +import Data.String +import Data.Map (Map) +import Data.List.NonEmpty (NonEmpty) +import Control.Monad.Logger (LogSource, LogLevel, Loc, LogStr) +import Data.Text (Text) +import Data.Acquire +import Database.Persist.Class.PersistStore +import Conduit +import Database.Persist.Types.Base +import Data.Int +import Data.IORef +import Control.Monad.Reader +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel + +-- | A 'SqlBackend' represents a handle or connection to a database. It +-- contains functions and values that allow databases to have more +-- optimized implementations, as well as references that benefit +-- performance and sharing. +-- +-- Instead of using the 'SqlBackend' constructor directly, use the +-- 'mkSqlBackend' function. +-- +-- A 'SqlBackend' is *not* thread-safe. You should not assume that +-- a 'SqlBackend' can be shared among threads and run concurrent queries. +-- This *will* result in problems. Instead, you should create a @'Pool' +-- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in +-- multi-threaded applications. +-- +-- To run actions in the @persistent@ library, you should use the +-- 'runSqlConn' function. If you're using a multithreaded application, use +-- the 'runSqlPool' function. +data SqlBackend = SqlBackend + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -- ^ SQL for inserting many rows and returning their primary keys, for + -- backends that support this functionality. If 'Nothing', rows will be + -- inserted one-at-a-time using 'connInsertSql'. + , connUpsertSql :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -- ^ Some databases support performing UPSERT _and_ RETURN entity + -- in a single call. + -- + -- This field when set will be used to generate the UPSERT+RETURN sql given + -- * an entity definition + -- * updates to be run on unique key(s) collision + -- + -- When left as 'Nothing', we find the unique key from entity def before + -- * trying to fetch an entity by said key + -- * perform an update when result found, else issue an insert + -- * return new entity from db + -- + -- @since 2.6 + , connPutManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk UPSERT, specifically + -- "insert or replace many records" in a single call. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a PUT MANY sql with placeholders for records + -- + -- When left as 'Nothing', we default to using 'defaultPutMany'. + -- + -- @since 2.8.1 + , connStmtMap :: IORef (Map Text Statement) + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + , connMaxParams :: Maybe Int + -- ^ Some databases (probably only Sqlite) have a limit on how + -- many question-mark parameters may be used in a statement + -- + -- @since 2.6.1 + , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk an atomic+bulk INSERT where + -- constraint conflicting entities can replace existing entities. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a INSERT sql with placeholders for primary+record fields + -- + -- When left as 'Nothing', we default to using 'defaultRepsertMany'. + -- + -- @since 2.9.0 + } + +-- | A function for creating a value of the 'SqlBackend' type. You should prefer +-- to use this instead of the constructor for 'SqlBackend', because default +-- values for this will be provided for new fields on the record when new +-- functionality is added. +-- +-- @since 2.13.0.0 +mkSqlBackend :: MkSqlBackendArgs -> SqlBackend +mkSqlBackend MkSqlBackendArgs {..} = + SqlBackend + { connMaxParams = Nothing + , connRepsertManySql = Nothing + , connPutManySql = Nothing + , connUpsertSql = Nothing + , connInsertManySql = Nothing + , .. + } + +instance HasPersistBackend SqlBackend where + type BaseBackend SqlBackend = SqlBackend + persistBackend = id + +instance IsPersistBackend SqlBackend where + mkPersistBackend = id diff --git a/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs b/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs new file mode 100644 index 000000000..90a69528b --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs @@ -0,0 +1,9 @@ +module Database.Persist.SqlBackend.Internal.InsertSqlResult where + +import Database.Persist.Types.Base (PersistValue) +import Data.Text (Text) + +data InsertSqlResult + = ISRSingle Text + | ISRInsertGet Text Text + | ISRManyKeys Text [PersistValue] diff --git a/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs new file mode 100644 index 000000000..951a48cf1 --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs @@ -0,0 +1,18 @@ +module Database.Persist.SqlBackend.Internal.IsolationLevel where + +import Data.String (IsString(..)) + +-- | Please refer to the documentation for the database in question for a full +-- overview of the semantics of the varying isloation levels +data IsolationLevel = ReadUncommitted + | ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Enum, Ord, Bounded) + +makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s +makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of + ReadUncommitted -> "READ UNCOMMITTED" + ReadCommitted -> "READ COMMITTED" + RepeatableRead -> "REPEATABLE READ" + Serializable -> "SERIALIZABLE" diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs new file mode 100644 index 000000000..4277cf760 --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.MkSqlBackend where + +import Conduit +import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr) +import Control.Monad.Reader +import Data.Acquire +import Data.IORef +import Data.Int +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.String +import Data.Text (Text) +import Database.Persist.Class.PersistStore +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.Types.Base + +-- | This type shares many of the same field names as the 'SqlBackend' type. +-- It's useful for library authors to use this when migrating from using the +-- 'SqlBackend' constructor directly to the 'mkSqlBackend' function. +-- +-- This type will only contain required fields for constructing a 'SqlBackend'. +-- For fields that aren't present on this record, you'll want to use the various +-- @set@ functions or +-- +-- @since 2.13.0.0 +data MkSqlBackendArgs = MkSqlBackendArgs + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connStmtMap :: IORef (Map Text Statement) + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + } + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () diff --git a/persistent/Database/Persist/SqlBackend/Internal/Statement.hs b/persistent/Database/Persist/SqlBackend/Internal/Statement.hs new file mode 100644 index 000000000..ef69a644c --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/Statement.hs @@ -0,0 +1,19 @@ +{-# language RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.Statement where + +import Data.Acquire +import Database.Persist.Types.Base +import Data.Int +import Conduit + +-- | A 'Statement' is a representation of a database query that has been +-- prepared and stored on the server side. +data Statement = Statement + { stmtFinalize :: IO () + , stmtReset :: IO () + , stmtExecute :: [PersistValue] -> IO Int64 + , stmtQuery :: forall m. MonadIO m + => [PersistValue] + -> Acquire (ConduitM () [PersistValue] m ()) + } diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index b4f53090d..61c687ed8 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -58,6 +58,13 @@ library Database.Persist.Sql.Util Database.Persist.Sql.Types.Internal + Database.Persist.SqlBackend + Database.Persist.SqlBackend.Internal + Database.Persist.SqlBackend.Internal.InsertSqlResult + Database.Persist.SqlBackend.Internal.IsolationLevel + Database.Persist.SqlBackend.Internal.Statement + Database.Persist.SqlBackend.Internal.MkSqlBackend + Database.Persist.Class.DeleteCascade Database.Persist.Class.PersistEntity Database.Persist.Class.PersistQuery diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 67a2c73e0..7e3f9449e 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -22,7 +22,7 @@ import Data.Aeson import qualified Data.ByteString.Char8 as BS8 import Database.Persist.Class.PersistField -import Database.Persist.Quasi +import Database.Persist.Quasi.Internal import Database.Persist.Types import qualified Database.Persist.THSpec as THSpec From 8d5c9f255ca72ee4fca2d1594d527da400cd9cf0 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 7 Apr 2021 08:43:31 -0600 Subject: [PATCH 04/14] suppor tother sql dbs --- persistent-mysql/ChangeLog.md | 6 + persistent-mysql/Database/Persist/MySQL.hs | 177 ++++++++---------- persistent-mysql/persistent-mysql.cabal | 2 +- persistent-postgresql/ChangeLog.md | 5 + .../persistent-postgresql.cabal | 4 +- persistent-postgresql/test/ArrayAggTest.hs | 2 +- persistent-postgresql/test/PgInit.hs | 3 +- persistent-sqlite/ChangeLog.md | 5 + persistent-sqlite/Database/Persist/Sqlite.hs | 118 ++++++------ persistent-sqlite/persistent-sqlite.cabal | 2 +- persistent/ChangeLog.md | 18 ++ persistent/Database/Persist/SqlBackend.hs | 10 + 12 files changed, 189 insertions(+), 163 deletions(-) diff --git a/persistent-mysql/ChangeLog.md b/persistent-mysql/ChangeLog.md index 0f2702831..fc2d1cd03 100644 --- a/persistent-mysql/ChangeLog.md +++ b/persistent-mysql/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-mysql +## 2.13.0.0 + +* [#]() + * Support `persistent-2.13` + * Remove the deprecated `SomeField` type and pattern. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index c29751819..cb2573d30 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -26,8 +26,6 @@ module Database.Persist.MySQL , insertOnDuplicateKeyUpdate , insertManyOnDuplicateKeyUpdate , HandleUpdateCollision - , pattern SomeField - , SomeField , copyField , copyUnlessNull , copyUnlessEmpty @@ -72,6 +70,7 @@ import qualified Data.Text.IO as T import System.Environment (getEnvironment) import Database.Persist.Sql +import Database.Persist.SqlBackend import Database.Persist.Sql.Types.Internal (makeIsolationLevelStatement) import qualified Database.Persist.Sql.Util as Util @@ -86,40 +85,40 @@ import qualified Database.MySQL.Simple.Types as MySQL -- The pool is properly released after the action finishes using -- it. Note that you should not use the given 'ConnectionPool' -- outside the action since it may be already been released. -withMySQLPool :: (MonadLoggerIO m, MonadUnliftIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> Int - -- ^ Number of connections to be kept open in the pool. - -> (Pool SqlBackend -> m a) - -- ^ Action to be executed that uses the connection pool. - -> m a +withMySQLPool + :: (MonadLoggerIO m, MonadUnliftIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the connection pool. + -> m a withMySQLPool ci = withSqlPool $ open' ci - -- | Create a MySQL connection pool. Note that it's your -- responsibility to properly close the connection pool when -- unneeded. Use 'withMySQLPool' for automatic resource control. -createMySQLPool :: (MonadUnliftIO m, MonadLoggerIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> Int - -- ^ Number of connections to be kept open in the pool. - -> m (Pool SqlBackend) +createMySQLPool + :: (MonadUnliftIO m, MonadLoggerIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) createMySQLPool ci = createSqlPool $ open' ci - -- | Same as 'withMySQLPool', but instead of opening a pool -- of connections, only one connection is opened. -withMySQLConn :: (MonadUnliftIO m, MonadLoggerIO m) - => MySQL.ConnectInfo - -- ^ Connection information. - -> (SqlBackend -> m a) - -- ^ Action to be executed that uses the connection. - -> m a +withMySQLConn + :: (MonadUnliftIO m, MonadLoggerIO m) + => MySQL.ConnectInfo + -- ^ Connection information. + -> (SqlBackend -> m a) + -- ^ Action to be executed that uses the connection. + -> m a withMySQLConn = withSqlConn . open' - -- | Internal function that opens a connection to the MySQL -- server. open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend @@ -127,32 +126,30 @@ open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! smap <- newIORef $ Map.empty - return $ SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Nothing - , connUpsertSql = Nothing - , connPutManySql = Just putManySql - , connClose = MySQL.close conn - , connMigrateSql = migrate' ci - , connBegin = \_ mIsolation -> do - forM_ mIsolation $ \iso -> MySQL.execute_ conn (makeIsolationLevelStatement iso) - MySQL.execute_ conn "start transaction" >> return () - , connCommit = const $ MySQL.commit conn - , connRollback = const $ MySQL.rollback conn - , connEscapeFieldName = T.pack . escapeF - , connEscapeTableName = T.pack . escapeE . entityDB - , connEscapeRawName = T.pack . escapeDBName . T.unpack - , connNoLimit = "LIMIT 18446744073709551615" - -- This noLimit is suggested by MySQL's own docs, see - -- - , connRDBMS = "mysql" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" - , connLogFunc = logFunc - , connMaxParams = Nothing - , connRepsertManySql = Just repsertManySql - } + return $ + setConnPutManySql putManySql $ + setConnRepsertManySql repsertManySql $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = MySQL.close conn + , connMigrateSql = migrate' ci + , connBegin = \_ mIsolation -> do + forM_ mIsolation $ \iso -> MySQL.execute_ conn (makeIsolationLevelStatement iso) + MySQL.execute_ conn "start transaction" >> return () + , connCommit = const $ MySQL.commit conn + , connRollback = const $ MySQL.rollback conn + , connEscapeFieldName = T.pack . escapeF + , connEscapeTableName = T.pack . escapeE . entityDB + , connEscapeRawName = T.pack . escapeDBName . T.unpack + , connNoLimit = "LIMIT 18446744073709551615" + -- This noLimit is suggested by MySQL's own docs, see + -- + , connRDBMS = "mysql" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" + , connLogFunc = logFunc + } -- | Prepare a query. We don't support prepared statements, but -- we'll do some client-side preprocessing here. @@ -1244,37 +1241,34 @@ mockMigrate _connectInfo allDefs _getter val = do -- the actual database isn't already present in the system. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - }, - connInsertManySql = Nothing, - connInsertSql = undefined, - connStmtMap = smap, - connClose = undefined, - connMigrateSql = mockMigrate undefined, - connBegin = undefined, - connCommit = undefined, - connRollback = undefined, - connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB, - connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . entityDB, - connEscapeRawName = T.pack . escapeDBName . T.unpack, - connNoLimit = undefined, - connRDBMS = undefined, - connLimitOffset = undefined, - connLogFunc = undefined, - connUpsertSql = undefined, - connPutManySql = undefined, - connMaxParams = Nothing, - connRepsertManySql = Nothing - } - result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend - mapM_ T.putStrLn $ map snd $ snd resp + smap <- newIORef $ Map.empty + let sqlbackend = + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connInsertSql = undefined + , connStmtMap = smap + , connClose = undefined + , connMigrateSql = mockMigrate undefined + , connBegin = undefined + , connCommit = undefined + , connRollback = undefined + , connEscapeFieldName = T.pack . escapeDBName . T.unpack . unFieldNameDB + , connEscapeTableName = T.pack . escapeDBName . T.unpack . unEntityNameDB . entityDB + , connEscapeRawName = T.pack . escapeDBName . T.unpack + , connNoLimit = undefined + , connRDBMS = undefined + , connLimitOffset = undefined + , connLogFunc = undefined + } + result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp -- | MySQL specific 'upsert_'. This will prevent multiple queries, when one will -- do. The record will be inserted into the database. In the event that the @@ -1299,21 +1293,10 @@ insertOnDuplicateKeyUpdate record = -- -- @since 2.8.0 data HandleUpdateCollision record where - -- | Copy the field directly from the record. - CopyField :: EntityField record typ -> HandleUpdateCollision record - -- | Only copy the field if it is not equal to the provided value. - CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record - --- | An alias for 'HandleUpdateCollision'. The type previously was only --- used to copy a single value, but was expanded to be handle more complex --- queries. --- --- @since 2.6.2 -type SomeField = HandleUpdateCollision - -pattern SomeField :: EntityField record typ -> SomeField record -pattern SomeField x = CopyField x -{-# DEPRECATED SomeField "The type SomeField is deprecated. Use the type HandleUpdateCollision instead, and use the function copyField instead of the data constructor." #-} + -- | Copy the field directly from the record. + CopyField :: EntityField record typ -> HandleUpdateCollision record + -- | Only copy the field if it is not equal to the provided value. + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record -- | Copy the field into the database only if the value in the -- corresponding record is non-@NULL@. diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index f17a26847..64639fab1 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -1,5 +1,5 @@ name: persistent-mysql -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Felipe Lessa , Michael Snoyman diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 6350581ef..a9c2a443d 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-postgresql +## 2.13.0.0 + +* [#]() + * Support `persistent-2.13.0.0` + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 6f5f6501d..c01043cde 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , attoparsec , blaze-builder diff --git a/persistent-postgresql/test/ArrayAggTest.hs b/persistent-postgresql/test/ArrayAggTest.hs index 1f8167165..b8902a114 100644 --- a/persistent-postgresql/test/ArrayAggTest.hs +++ b/persistent-postgresql/test/ArrayAggTest.hs @@ -43,7 +43,7 @@ specs = do , UserPT "c" $ Just "d" , UserPT "e" Nothing , UserPT "g" $ Just "h" ] - escape <- asks connEscapeRawName + escape <- getEscapeRawNameFunction let query = T.concat [ "SELECT array_agg(", escape dbField, ") " , "FROM ", escape "UserPT" ] diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index d2fcb85dd..de4af9b60 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -17,6 +17,7 @@ module PgInit ( , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql + , module Database.Persist.SqlBackend , module Database.Persist , module Database.Persist.Sql.Raw.QQ , module Init @@ -47,6 +48,7 @@ import Control.Monad.Trans.Reader import Data.Aeson (Value(..)) import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) import Database.Persist.Sql.Raw.QQ +import Database.Persist.SqlBackend import Database.Persist.Postgresql.JSON() import Test.Hspec import Test.QuickCheck.Instances () @@ -56,7 +58,6 @@ import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) import Test.QuickCheck import Control.Monad (unless, (>=>)) -import Control.Monad.IO.Class import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index 9aa454e68..74db3c5d2 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-sqlite +## 2.13.0.0 (unreleased) + +* [#]() + * Support `persistent-2.13.0.0` + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 8b2cd8c51..5b636f541 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -90,6 +90,7 @@ import UnliftIO.Resource (ResourceT, runResourceT) import Database.Persist.Compatible #endif import Database.Persist.Sql +import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util import qualified Database.Sqlite as Sqlite @@ -267,28 +268,27 @@ wrapConnectionInfo connInfo conn logFunc = do Sqlite.finalize stmt smap <- newIORef $ Map.empty - return $ SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connUpsertSql = Nothing - , connPutManySql = Just putManySql - , connInsertManySql = Nothing - , connClose = Sqlite.close conn - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = logFunc - , connMaxParams = Just 999 - , connRepsertManySql = Just repsertManySql - } + return $ + setConnMaxParams 999 $ + setConnPutManySql putManySql $ + setConnRepsertManySql repsertManySql $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = Sqlite.close conn + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = logFunc + } where helper t getter = do stmt <- getter t @@ -454,44 +454,42 @@ migrate' allDefs getter val = do -- with the difference that an actual database isn't needed for it. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty - let sqlbackend = SqlBackend - { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - } - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Nothing - , connClose = undefined - , connMigrateSql = migrate' - , connBegin = \f _ -> helper "BEGIN" f - , connCommit = helper "COMMIT" - , connRollback = ignoreExceptions . helper "ROLLBACK" - , connEscapeFieldName = escape . unFieldNameDB - , connEscapeTableName = escape . unEntityNameDB . entityDB - , connEscapeRawName = escape - , connNoLimit = "LIMIT -1" - , connRDBMS = "sqlite" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" - , connLogFunc = undefined - , connUpsertSql = undefined - , connPutManySql = undefined - , connMaxParams = Just 999 - , connRepsertManySql = Nothing - } - result = runReaderT . runWriterT . runWriterT $ mig - resp <- result sqlbackend - mapM_ TIO.putStrLn $ map snd $ snd resp - where - helper t getter = do - stmt <- getter t - _ <- stmtExecute stmt [] - stmtReset stmt - ignoreExceptions = E.handle (\(_ :: E.SomeException) -> return ()) + smap <- newIORef $ Map.empty + let sqlbackend = + setConnMaxParams 999 $ + mkSqlBackend MkSqlBackendArgs + { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = undefined + , connMigrateSql = migrate' + , connBegin = \f _ -> helper "BEGIN" f + , connCommit = helper "COMMIT" + , connRollback = ignoreExceptions . helper "ROLLBACK" + , connEscapeFieldName = escape . unFieldNameDB + , connEscapeTableName = escape . unEntityNameDB . entityDB + , connEscapeRawName = escape + , connNoLimit = "LIMIT -1" + , connRDBMS = "sqlite" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" + , connLogFunc = undefined + } + result = runReaderT . runWriterT . runWriterT $ mig + resp <- result sqlbackend + mapM_ TIO.putStrLn $ map snd $ snd resp + where + helper t getter = do + stmt <- getter t + _ <- stmtExecute stmt [] + stmtReset stmt + ignoreExceptions = + E.handle (\(_ :: E.SomeException) -> return ()) -- | Check if a column name is listed as the "safe to remove" in the entity -- list. diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index 81c0ab452..ac881d056 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 4cb4da320..cf2516fdb 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -10,6 +10,24 @@ release new functionality without breaking your code. It's recommended to switch to using the smart constructor functions and setter functions that are now exported from `Database.Persist.Sql` instead. + * A new API is available for constructing and using a `SqlBackend`, provided + in `Database.Persist.SqlBackend`. Instead of using the `SqlBackend` + directly, use `mkSqlBackend` and the datatype `MkSqlBackendArgs`. The + `MkSqlBackendArgs` record has the same field names as the `SqlBackend`, so + the translation is easy: + ```diff +- SqlBackend ++ mkSqlBackend MkSqlBackendArgs + { connInsertSql = ... + , connCommit = ... + , connEscapeFieldName = ... + , connEscapeTableName = ... + , etc + } + ``` + Some fields were omitted in `MkSqlBackendArgs`. These fields are + *optional* - they provide enhanced or backend-specific functionality. For + these, use the setter functions like `setConnUpsertSql`. * Previously hidden modules are now exposed under the `Internal` namespace. ## 2.12.0.2 diff --git a/persistent/Database/Persist/SqlBackend.hs b/persistent/Database/Persist/SqlBackend.hs index 510d3e3bc..e93748ae6 100644 --- a/persistent/Database/Persist/SqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend.hs @@ -12,6 +12,7 @@ module Database.Persist.SqlBackend , getEscapedFieldName , getEscapedRawName + , getEscapeRawNameFunction , setConnMaxParams , setConnRepsertManySql , setConnInsertManySql @@ -90,6 +91,15 @@ getEscapedRawName name = do func <- asks (SqlBackend.connEscapeRawName . projectBackend) pure (func name) +-- | Return the function for escaping a raw name. +-- +-- @since 2.13.0.0 +getEscapeRawNameFunction + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m (Text -> Text) +getEscapeRawNameFunction = do + asks (SqlBackend.connEscapeRawName . projectBackend) + -- | Set the maximum parameters that may be issued in a given SQL query. This -- should be used only if the database backend have this limitation. -- From e45b9ff179beba97a0026e0266db64eb7632d3ab Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 7 Apr 2021 15:33:09 -0600 Subject: [PATCH 05/14] bounds --- persistent-mysql/persistent-mysql.cabal | 2 +- persistent-sqlite/persistent-sqlite.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/persistent-mysql.cabal b/persistent-mysql/persistent-mysql.cabal index 64639fab1..d9e6708f3 100644 --- a/persistent-mysql/persistent-mysql.cabal +++ b/persistent-mysql/persistent-mysql.cabal @@ -28,7 +28,7 @@ extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10.8 diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index ac881d056..1ccc12f1b 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -44,7 +44,7 @@ flag use-stat4 library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.13 && < 3 , aeson >= 1.0 , bytestring >= 0.10 , conduit >= 1.2.12 From f5f2367f3d4c3ca6d5b2b30b029e35787b4caf19 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 7 Apr 2021 15:41:02 -0600 Subject: [PATCH 06/14] asdf --- persistent/persistent.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 61c687ed8..b47933a20 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.0.2 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman From 3e2975d7110b5330f987e1ceef747c43d0c6e0a9 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 7 Apr 2021 16:27:57 -0600 Subject: [PATCH 07/14] import data.monoid --- .../Database/Persist/SqlBackend/Internal/IsolationLevel.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs index 951a48cf1..d4c9926bd 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs @@ -1,6 +1,7 @@ module Database.Persist.SqlBackend.Internal.IsolationLevel where import Data.String (IsString(..)) +import Data.Monoid ((<>)) -- TODO: remove when GHC-8.2 support is dropped -- | Please refer to the documentation for the database in question for a full -- overview of the semantics of the varying isloation levels From 89e64542d39d6c65c89cf0f91839a22741a0227b Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Mon, 29 Mar 2021 15:19:06 -0700 Subject: [PATCH 08/14] Add instrumentation hook for wrapping statements --- persistent-mysql/Database/Persist/MySQL.hs | 2 ++ persistent-postgresql/Database/Persist/Postgresql.hs | 2 ++ persistent-sqlite/Database/Persist/Sqlite.hs | 2 ++ persistent/Database/Persist/Sql/Raw.hs | 4 ++-- .../Database/Persist/SqlBackend/Internal/MkSqlBackend.hs | 3 +++ 5 files changed, 11 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index cb2573d30..d43d57d07 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -149,6 +149,7 @@ open' ci logFunc = do , connRDBMS = "mysql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT 18446744073709551615" , connLogFunc = logFunc + , connStatementMiddleware = const pure } -- | Prepare a query. We don't support prepared statements, but @@ -1265,6 +1266,7 @@ mockMigration mig = do , connRDBMS = undefined , connLimitOffset = undefined , connLogFunc = undefined + , connStatementMiddleware = const pure } result = runReaderT . runWriterT . runWriterT $ mig resp <- result sqlbackend diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 49f635dd6..3b1f0d39b 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -363,6 +363,7 @@ createBackend logFunc serverVersion smap conn = , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" , connLogFunc = logFunc + , connStatementMiddleware = const pure } prepare' :: PG.Connection -> Text -> IO Statement @@ -1717,6 +1718,7 @@ mockMigration mig = do , connRDBMS = undefined , connLimitOffset = undefined , connLogFunc = undefined + , connStatementMiddleware = const pure } result = runReaderT $ runWriterT $ runWriterT mig resp <- result sqlbackend diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 5b636f541..d891d259f 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -288,6 +288,7 @@ wrapConnectionInfo connInfo conn logFunc = do , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = logFunc + , connStatementMiddleware = const pure } where helper t getter = do @@ -479,6 +480,7 @@ mockMigration mig = do , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = undefined + , connStatementMiddleware = const pure } result = runReaderT . runWriterT . runWriterT $ mig resp <- result sqlbackend diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index 8c5eda0de..c77e0cb2c 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -78,7 +78,7 @@ getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do smap <- liftIO $ readIORef $ connStmtMap conn case Map.lookup sql smap of - Just stmt -> return stmt + Just stmt -> connStatementMiddleware conn sql stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql iactive <- liftIO $ newIORef True @@ -102,7 +102,7 @@ getStmtConn conn sql = do else liftIO $ throwIO $ StatementAlreadyFinalized sql } liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap - return stmt + connStatementMiddleware conn sql stmt -- | Execute a raw SQL statement and return its results as a -- list. If you do not expect a return value, use of diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs index 4277cf760..81e5c9e3d 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -80,6 +80,9 @@ data MkSqlBackendArgs = MkSqlBackendArgs -- queries are the superior way to offer pagination. , connLogFunc :: LogFunc -- ^ A log function for the 'SqlBackend' to use. + , connStatementMiddleware :: Text -> Statement -> IO Statement + -- ^ Provide facilities for injecting middleware into statements + -- to allow for instrumenting queries. } type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () From 310b3c963d9dc8794e374a3cbb463e4a99ce6806 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Tue, 30 Mar 2021 21:23:13 -0700 Subject: [PATCH 09/14] Allow providing alternate statement cache implementations to SqlBackends --- .../Database/Persist/Postgresql.hs | 63 ++++++++++--------- persistent/Database/Persist/Sql/Raw.hs | 8 +-- persistent/Database/Persist/Sql/Run.hs | 9 ++- persistent/Database/Persist/Sql/Types.hs | 2 + .../SqlBackend/Internal/MkSqlBackend.hs | 3 +- .../SqlBackend/Internal/StatementCache.hs | 54 ++++++++++++++++ 6 files changed, 98 insertions(+), 41 deletions(-) create mode 100644 persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 3b1f0d39b..dc86ae929 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -126,7 +125,7 @@ withPostgresqlPool :: (MonadLoggerIO m, MonadUnliftIO m) -- ^ Action to be executed that uses the -- connection pool. -> m a -withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci +withPostgresqlPool = withPostgresqlPoolWithVersion getServerVersion -- | Same as 'withPostgresPool', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). @@ -146,7 +145,7 @@ withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) -> m a withPostgresqlPoolWithVersion getVerDouble ci = do let getVer = oldGetVersionToNew getVerDouble - withSqlPool $ open' (const $ return ()) getVer ci + withSqlPool $ open' (defaultPostgresConfHooks { pgConfHooksGetServerVersion = getVer }) ci -- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. -- @@ -159,9 +158,7 @@ withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLoggerIO m) -- connection pool. -> m a withPostgresqlPoolWithConf conf hooks = do - let getVer = pgConfHooksGetServerVersion hooks - modConn = pgConfHooksAfterCreate hooks - let logFuncToBackend = open' modConn getVer (pgConnStr conf) + let logFuncToBackend = open' hooks (pgConnStr conf) withSqlPoolWithConfig logFuncToBackend (postgresConfToConnectionPoolConfig conf) -- | Create a PostgreSQL connection pool. Note that it's your @@ -207,7 +204,11 @@ createPostgresqlPoolModifiedWithVersion -> m (Pool SqlBackend) createPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do let getVer = oldGetVersionToNew getVerDouble - createSqlPool $ open' modConn getVer ci + hooks = defaultPostgresConfHooks + { pgConfHooksAfterCreate = modConn + , pgConfHooksGetServerVersion = getVer + } + createSqlPool $ open' hooks ci -- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. -- @@ -218,9 +219,7 @@ createPostgresqlPoolWithConf -> PostgresConfHooks -- ^ Record of callback functions -> m (Pool SqlBackend) createPostgresqlPoolWithConf conf hooks = do - let getVer = pgConfHooksGetServerVersion hooks - modConn = pgConfHooksAfterCreate hooks - createSqlPoolWithConfig (open' modConn getVer (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf) + createSqlPoolWithConfig (open' hooks (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf) postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig postgresConfToConnectionPoolConfig conf = @@ -249,17 +248,18 @@ withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) -> m a withPostgresqlConnWithVersion getVerDouble = do let getVer = oldGetVersionToNew getVerDouble - withSqlConn . open' (const $ return ()) getVer + withSqlConn . open' (defaultPostgresConfHooks { pgConfHooksGetServerVersion = getVer }) open' - :: (PG.Connection -> IO ()) - -> (PG.Connection -> IO (NonEmpty Word)) - -> ConnectionString -> LogFunc -> IO SqlBackend -open' modConn getVer cstr logFunc = do + :: PostgresConfHooks + -> ConnectionString + -> LogFunc + -> IO SqlBackend +open' PostgresConfHooks{..} cstr logFunc = do conn <- PG.connectPostgreSQL cstr - modConn conn - ver <- getVer conn - smap <- newIORef $ Map.empty + pgConfHooksAfterCreate conn + ver <- pgConfHooksGetServerVersion conn + smap <- pgConfHooksCreateStatementCache return $ createBackend logFunc ver smap conn -- | Gets the PostgreSQL server version @@ -295,10 +295,9 @@ getServerVersionNonEmpty conn = do -- so depending upon that we have to choose how the sql query is generated. -- upsertFunction :: Double -> Maybe (EntityDef -> Text -> Text) upsertFunction :: a -> NonEmpty Word -> Maybe a -upsertFunction f version = if (version >= postgres9dot5) +upsertFunction f version = if version >= postgres9dot5 then Just f else Nothing - where postgres9dot5 :: NonEmpty Word postgres9dot5 = 9 NEL.:| [5] @@ -310,7 +309,7 @@ minimumPostgresVersion :: NonEmpty Word minimumPostgresVersion = 9 NEL.:| [4] oldGetVersionToNew :: (PG.Connection -> IO (Maybe Double)) -> (PG.Connection -> IO (NonEmpty Word)) -oldGetVersionToNew oldFn = \conn -> do +oldGetVersionToNew oldFn conn = do mDouble <- oldFn conn case mDouble of Nothing -> pure minimumPostgresVersion @@ -328,14 +327,14 @@ openSimpleConn = openSimpleConnWithVersion getServerVersion -- @since 2.9.1 openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend openSimpleConnWithVersion getVerDouble logFunc conn = do - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache serverVersion <- oldGetVersionToNew getVerDouble conn return $ createBackend logFunc serverVersion smap conn -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection. createBackend :: LogFunc -> NonEmpty Word - -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend + -> StatementCache -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ @@ -421,7 +420,7 @@ upsertSql' ent uniqs updateVal = wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs singleClause :: FieldNameDB -> Text - singleClause field = escapeE (entityDB ent) <> "." <> (escapeF field) <> " =?" + singleClause field = escapeE (entityDB ent) <> "." <> escapeF field <> " =?" -- | SQL for inserting multiple rows at once and returning their primary keys. insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult @@ -607,7 +606,7 @@ instance PGFF.FromField PgInterval where nominalDiffTime :: P.Parser NominalDiffTime nominalDiffTime = do (s, h, m, ss) <- interval - let pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h)) + let pico = ss + 60 * fromIntegral m + 60 * 60 * fromIntegral (abs h) return . fromRational . toRational $ if s then (-pico) else pico fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" @@ -798,7 +797,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do -- for https://github.com/yesodweb/persistent/issues/152 createText newcols fdefs_ udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt + addTable newcols entity : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] @@ -1075,7 +1074,7 @@ getColumn getter tableName' [ PersistText columnName let cname = FieldNameDB columnName - ref <- lift $ fmap join $ traverse (getRef cname) refName_ + ref <- lift $ join <$> traverse (getRef cname) refName_ return Column { cName = cname @@ -1537,9 +1536,9 @@ instance FromJSON PostgresConf where port <- o .:? "port" .!= 5432 user <- o .: "user" password <- o .: "password" - poolSize <- o .:? "poolsize" .!= (connectionPoolConfigSize defaultPoolConfig) - poolStripes <- o .:? "stripes" .!= (connectionPoolConfigStripes defaultPoolConfig) - poolIdleTimeout <- o .:? "idleTimeout" .!= (floor $ connectionPoolConfigIdleTimeout defaultPoolConfig) + poolSize <- o .:? "poolsize" .!= connectionPoolConfigSize defaultPoolConfig + poolStripes <- o .:? "stripes" .!= connectionPoolConfigStripes defaultPoolConfig + poolIdleTimeout <- o .:? "idleTimeout" .!= floor (connectionPoolConfigIdleTimeout defaultPoolConfig) let ci = PG.ConnectInfo { PG.connectHost = host , PG.connectPort = port @@ -1604,6 +1603,7 @@ data PostgresConfHooks = PostgresConfHooks -- The default implementation does nothing. -- -- @since 2.11.0 + , pgConfHooksCreateStatementCache :: IO StatementCache } -- | Default settings for 'PostgresConfHooks'. See the individual fields of 'PostgresConfHooks' for the default values. @@ -1613,6 +1613,7 @@ defaultPostgresConfHooks :: PostgresConfHooks defaultPostgresConfHooks = PostgresConfHooks { pgConfHooksGetServerVersion = getServerVersionNonEmpty , pgConfHooksAfterCreate = const $ pure () + , pgConfHooksCreateStatementCache = makeSimpleStatementCache } @@ -1694,7 +1695,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do -- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache let sqlbackend = mkSqlBackend MkSqlBackendArgs { connPrepare = \_ -> do diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index c77e0cb2c..c66397ba1 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -9,7 +9,6 @@ import Control.Monad.Trans.Resource (MonadResource,release) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) import Data.Conduit import Data.IORef (writeIORef, readIORef, newIORef) -import qualified Data.Map as Map import Data.Int (Int64) import Data.Text (Text, pack) import qualified Data.Text as T @@ -19,6 +18,7 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal import Database.Persist.SqlBackend.Internal import Database.Persist.Sql.Class +import Database.Persist.Sql.Types.Internal (statementCacheLookup, StatementCache (statementCacheInsert)) rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text @@ -76,8 +76,8 @@ getStmt sql = do getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do - smap <- liftIO $ readIORef $ connStmtMap conn - case Map.lookup sql smap of + smap <- liftIO $ statementCacheLookup (connStmtMap conn) sql + case smap of Just stmt -> connStatementMiddleware conn sql stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql @@ -101,7 +101,7 @@ getStmtConn conn sql = do then stmtQuery stmt' x else liftIO $ throwIO $ StatementAlreadyFinalized sql } - liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap + liftIO $ statementCacheInsert (connStmtMap conn) sql stmt connStatementMiddleware conn sql stmt -- | Execute a raw SQL statement and return its results as a diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index d66c72a9c..1c0055591 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -9,10 +9,8 @@ import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with) -import Data.IORef (readIORef) import Data.Pool (Pool) import Data.Pool as P -import qualified Data.Map as Map import qualified Data.Text as T import Database.Persist.Class.PersistStore @@ -184,7 +182,7 @@ withSqlPool -> Int -- ^ connection count -> (Pool backend -> m a) -> m a -withSqlPool mkConn connCount f = withSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = connCount } ) f +withSqlPool mkConn connCount = withSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = connCount } ) -- | Creates a pool of connections to a SQL database which can be used by the @Pool backend -> m a@ function. -- After the function completes, the connections are destroyed. @@ -297,5 +295,6 @@ withSqlConn open f = do close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do - readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems - connClose $ projectBackend conn + let backend = projectBackend conn + statementCacheClear $ connStmtMap backend + connClose backend diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index fd0a4ddda..8fda3e23a 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -6,6 +6,8 @@ module Database.Persist.Sql.Types , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend , OverflowNatural(..) , ConnectionPoolConfig(..) + , StatementCache(..) + , makeSimpleStatementCache ) where import Database.Persist.Types.Base (FieldCascade) diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs index 81e5c9e3d..fa600dfda 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -14,6 +14,7 @@ import Data.String import Data.Text (Text) import Database.Persist.Class.PersistStore import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.StatementCache import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.Types.Base @@ -34,7 +35,7 @@ data MkSqlBackendArgs = MkSqlBackendArgs , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult -- ^ This function generates the SQL and values necessary for -- performing an insert against the database. - , connStmtMap :: IORef (Map Text Statement) + , connStmtMap :: InternalStatementCache -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () diff --git a/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs b/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs new file mode 100644 index 000000000..edb47cd9b --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs @@ -0,0 +1,54 @@ +module Database.Persist.SqlBackend.Internal.StatementCache + ( StatementCache(..) + , InternalStatementCache + , makeSimpleStatementCache + , internalizeStatementCache + ) where + +import Data.Foldable +import Data.IORef +import qualified Data.Map as Map +import Data.Text (Text) +import Database.Persist.SqlBackend.Internal.Statement + +class StatementCache c where + statementCacheLookup :: c -> Text -> IO (Maybe Statement) + statementCacheInsert :: c -> Text -> Statement -> IO () + statementCacheClear :: c -> IO () + statementCacheSize :: c -> IO Int + +data InternalStatementCache = InternalStatementCache + { _statementCacheLookup :: Text -> IO (Maybe Statement) + , _statementCacheInsert :: Text -> Statement -> IO () + , _statementCacheClear :: IO () + , _statementCacheSize :: IO Int + } + +instance StatementCache InternalStatementCache where + statementCacheLookup = _statementCacheLookup + statementCacheInsert = _statementCacheInsert + statementCacheClear = _statementCacheClear + statementCacheSize = _statementCacheSize + + +internalizeStatementCache :: StatementCache c => c -> InternalStatementCache +internalizeStatementCache c = InternalStatementCache + { _statementCacheLookup = statementCacheLookup c + , _statementCacheInsert = statementCacheInsert c + , _statementCacheClear = statementCacheClear c + , _statementCacheSize = statementCacheSize c + } + +makeSimpleStatementCache :: IO InternalStatementCache +makeSimpleStatementCache = do + stmtMap <- newIORef Map.empty + pure $ InternalStatementCache + { _statementCacheLookup = \sql -> Map.lookup sql <$> readIORef stmtMap + , _statementCacheInsert = \sql stmt -> + modifyIORef' stmtMap (Map.insert sql stmt) + , _statementCacheClear = do + oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) + traverse_ stmtFinalize oldStatements + , _statementCacheSize = Map.size <$> readIORef stmtMap + } + From 79725c12feecb70dc0bfd8c0439be1b1e0452acd Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Tue, 30 Mar 2021 21:28:36 -0700 Subject: [PATCH 10/14] Update MySQL and Sqlite libraries to use new StatementCache mechanism --- persistent-mysql/Database/Persist/MySQL.hs | 4 ++-- persistent-sqlite/Database/Persist/Sqlite.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index d43d57d07..d8205ca5f 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -125,7 +125,7 @@ open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache return $ setConnPutManySql putManySql $ setConnRepsertManySql repsertManySql $ @@ -1242,7 +1242,7 @@ mockMigrate _connectInfo allDefs _getter val = do -- the actual database isn't already present in the system. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache let sqlbackend = mkSqlBackend MkSqlBackendArgs { connPrepare = \_ -> do diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index d891d259f..69b3b3342 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -267,7 +267,7 @@ wrapConnectionInfo connInfo conn logFunc = do Sqlite.reset conn stmt Sqlite.finalize stmt - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache return $ setConnMaxParams 999 $ setConnPutManySql putManySql $ @@ -455,7 +455,7 @@ migrate' allDefs getter val = do -- with the difference that an actual database isn't needed for it. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- newIORef $ Map.empty + smap <- makeSimpleStatementCache let sqlbackend = setConnMaxParams 999 $ mkSqlBackend MkSqlBackendArgs From c6f90a22aa00606837f03c9c9ffeb5df72841c79 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Thu, 8 Apr 2021 11:31:28 -0700 Subject: [PATCH 11/14] Integrate middleware changes with internalization of SqlBackend --- persistent-mysql/Database/Persist/MySQL.hs | 4 +- .../Database/Persist/Postgresql.hs | 15 ++-- persistent-sqlite/Database/Persist/Sqlite.hs | 9 +-- persistent/Database/Persist/Sql/Raw.hs | 8 +- persistent/Database/Persist/Sql/Run.hs | 1 + persistent/Database/Persist/Sql/Types.hs | 2 - persistent/Database/Persist/SqlBackend.hs | 15 ++++ .../Database/Persist/SqlBackend/Internal.hs | 7 +- .../SqlBackend/Internal/MkSqlBackend.hs | 7 +- .../SqlBackend/Internal/StatementCache.hs | 63 ++++------------ .../Persist/SqlBackend/StatementCache.hs | 74 +++++++++++++++++++ persistent/persistent.cabal | 2 + 12 files changed, 132 insertions(+), 75 deletions(-) create mode 100644 persistent/Database/Persist/SqlBackend/StatementCache.hs diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index d8205ca5f..cd38e7e15 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -125,7 +125,7 @@ open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! - smap <- makeSimpleStatementCache + smap <- mkSimpleStatementCache return $ setConnPutManySql putManySql $ setConnRepsertManySql repsertManySql $ @@ -1242,7 +1242,7 @@ mockMigrate _connectInfo allDefs _getter val = do -- the actual database isn't already present in the system. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- makeSimpleStatementCache + smap <- mkSimpleStatementCache let sqlbackend = mkSqlBackend MkSqlBackendArgs { connPrepare = \_ -> do diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index dc86ae929..cbb8a77fd 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -90,6 +90,7 @@ import System.Environment (getEnvironment) import Database.Persist.Sql import Database.Persist.SqlBackend +import Database.Persist.SqlBackend.StatementCache import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection @@ -327,14 +328,14 @@ openSimpleConn = openSimpleConnWithVersion getServerVersion -- @since 2.9.1 openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend openSimpleConnWithVersion getVerDouble logFunc conn = do - smap <- makeSimpleStatementCache + smap <- mkSimpleStatementCache serverVersion <- oldGetVersionToNew getVerDouble conn return $ createBackend logFunc serverVersion smap conn -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection. createBackend :: LogFunc -> NonEmpty Word - -> StatementCache -> PG.Connection -> SqlBackend + -> MkStatementCache -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ @@ -342,7 +343,7 @@ createBackend logFunc serverVersion smap conn = maybe id setConnRepsertManySql (upsertFunction repsertManySql serverVersion) $ mkSqlBackend MkSqlBackendArgs { connPrepare = prepare' conn - , connStmtMap = smap + , connStmtMap = mkStatementCache smap , connInsertSql = insertSql' , connClose = PG.close conn , connMigrateSql = migrate' @@ -362,7 +363,6 @@ createBackend logFunc serverVersion smap conn = , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" , connLogFunc = logFunc - , connStatementMiddleware = const pure } prepare' :: PG.Connection -> Text -> IO Statement @@ -1603,7 +1603,7 @@ data PostgresConfHooks = PostgresConfHooks -- The default implementation does nothing. -- -- @since 2.11.0 - , pgConfHooksCreateStatementCache :: IO StatementCache + , pgConfHooksCreateStatementCache :: IO MkStatementCache } -- | Default settings for 'PostgresConfHooks'. See the individual fields of 'PostgresConfHooks' for the default values. @@ -1613,7 +1613,7 @@ defaultPostgresConfHooks :: PostgresConfHooks defaultPostgresConfHooks = PostgresConfHooks { pgConfHooksGetServerVersion = getServerVersionNonEmpty , pgConfHooksAfterCreate = const $ pure () - , pgConfHooksCreateStatementCache = makeSimpleStatementCache + , pgConfHooksCreateStatementCache = mkSimpleStatementCache } @@ -1695,7 +1695,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do -- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- makeSimpleStatementCache + smap <- mkStatementCache <$> mkSimpleStatementCache let sqlbackend = mkSqlBackend MkSqlBackendArgs { connPrepare = \_ -> do @@ -1719,7 +1719,6 @@ mockMigration mig = do , connRDBMS = undefined , connLimitOffset = undefined , connLogFunc = undefined - , connStatementMiddleware = const pure } result = runReaderT $ runWriterT $ runWriterT mig resp <- result sqlbackend diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 69b3b3342..f3ae397b7 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -76,8 +76,6 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as CL import qualified Data.HashMap.Lazy as HashMap import Data.Int (Int64) -import Data.IORef -import qualified Data.Map as Map import Data.Monoid ((<>)) import Data.Pool (Pool) import Data.Text (Text) @@ -91,6 +89,7 @@ import Database.Persist.Compatible #endif import Database.Persist.Sql import Database.Persist.SqlBackend +import Database.Persist.SqlBackend.StatementCache import qualified Database.Persist.Sql.Util as Util import qualified Database.Sqlite as Sqlite @@ -267,7 +266,7 @@ wrapConnectionInfo connInfo conn logFunc = do Sqlite.reset conn stmt Sqlite.finalize stmt - smap <- makeSimpleStatementCache + smap <- mkStatementCache <$> mkSimpleStatementCache return $ setConnMaxParams 999 $ setConnPutManySql putManySql $ @@ -288,7 +287,6 @@ wrapConnectionInfo connInfo conn logFunc = do , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = logFunc - , connStatementMiddleware = const pure } where helper t getter = do @@ -455,7 +453,7 @@ migrate' allDefs getter val = do -- with the difference that an actual database isn't needed for it. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- makeSimpleStatementCache + smap <- mkStatementCache <$> mkSimpleStatementCache let sqlbackend = setConnMaxParams 999 $ mkSqlBackend MkSqlBackendArgs @@ -480,7 +478,6 @@ mockMigration mig = do , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = undefined - , connStatementMiddleware = const pure } result = runReaderT . runWriterT . runWriterT $ mig resp <- result sqlbackend diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs index c66397ba1..767b6db65 100644 --- a/persistent/Database/Persist/Sql/Raw.hs +++ b/persistent/Database/Persist/Sql/Raw.hs @@ -16,9 +16,8 @@ import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal -import Database.Persist.SqlBackend.Internal import Database.Persist.Sql.Class -import Database.Persist.Sql.Types.Internal (statementCacheLookup, StatementCache (statementCacheInsert)) +import Database.Persist.SqlBackend.Internal.StatementCache rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text @@ -76,7 +75,8 @@ getStmt sql = do getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do - smap <- liftIO $ statementCacheLookup (connStmtMap conn) sql + let cacheKey = mkCacheKeyFromQuery sql + smap <- liftIO $ statementCacheLookup (connStmtMap conn) cacheKey case smap of Just stmt -> connStatementMiddleware conn sql stmt Nothing -> do @@ -101,7 +101,7 @@ getStmtConn conn sql = do then stmtQuery stmt' x else liftIO $ throwIO $ StatementAlreadyFinalized sql } - liftIO $ statementCacheInsert (connStmtMap conn) sql stmt + liftIO $ statementCacheInsert (connStmtMap conn) cacheKey stmt connStatementMiddleware conn sql stmt -- | Execute a raw SQL statement and return its results as a diff --git a/persistent/Database/Persist/Sql/Run.hs b/persistent/Database/Persist/Sql/Run.hs index 1c0055591..06723a21f 100644 --- a/persistent/Database/Persist/Sql/Run.hs +++ b/persistent/Database/Persist/Sql/Run.hs @@ -17,6 +17,7 @@ import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Raw +import Database.Persist.SqlBackend.Internal.StatementCache -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index 8fda3e23a..fd0a4ddda 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -6,8 +6,6 @@ module Database.Persist.Sql.Types , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend , OverflowNatural(..) , ConnectionPoolConfig(..) - , StatementCache(..) - , makeSimpleStatementCache ) where import Database.Persist.Types.Base (FieldCascade) diff --git a/persistent/Database/Persist/SqlBackend.hs b/persistent/Database/Persist/SqlBackend.hs index e93748ae6..6e304514b 100644 --- a/persistent/Database/Persist/SqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend.hs @@ -18,6 +18,7 @@ module Database.Persist.SqlBackend , setConnInsertManySql , setConnUpsertSql , setConnPutManySql + , setConnStatementMiddleware ) where import Control.Monad.Reader @@ -29,6 +30,7 @@ import qualified Database.Persist.SqlBackend.Internal as SqlBackend import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) import Database.Persist.Types.Base import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.Statement import Data.List.NonEmpty (NonEmpty) -- $utilities @@ -158,3 +160,16 @@ setConnPutManySql -> SqlBackend setConnPutManySql mkQuery sb = sb { connPutManySql = Just mkQuery } + +-- | Set the 'connPutManySql field on the 'SqlBackend'. This can be used to +-- locally alter the statement prior to the statement being queried or executed. +-- If this is not set, it will have no effect. +-- +-- @since 2.13.0.0 +setConnStatementMiddleware + :: (Text -> Statement -> IO Statement) + -> SqlBackend + -> SqlBackend +setConnStatementMiddleware middleware sb = + sb { connStatementMiddleware = middleware } + diff --git a/persistent/Database/Persist/SqlBackend/Internal.hs b/persistent/Database/Persist/SqlBackend/Internal.hs index 5f888cd56..c56df9446 100644 --- a/persistent/Database/Persist/SqlBackend/Internal.hs +++ b/persistent/Database/Persist/SqlBackend/Internal.hs @@ -15,6 +15,7 @@ import Database.Persist.Types.Base import Data.Int import Data.IORef import Control.Monad.Reader +import Database.Persist.SqlBackend.StatementCache import Database.Persist.SqlBackend.Internal.MkSqlBackend import Database.Persist.SqlBackend.Internal.Statement import Database.Persist.SqlBackend.Internal.InsertSqlResult @@ -74,7 +75,7 @@ data SqlBackend = SqlBackend -- When left as 'Nothing', we default to using 'defaultPutMany'. -- -- @since 2.8.1 - , connStmtMap :: IORef (Map Text Statement) + , connStmtMap :: StatementCache -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () @@ -137,6 +138,9 @@ data SqlBackend = SqlBackend -- When left as 'Nothing', we default to using 'defaultRepsertMany'. -- -- @since 2.9.0 + , connStatementMiddleware :: Text -> Statement -> IO Statement + -- ^ Provide facilities for injecting middleware into statements + -- to allow for instrumenting queries. } -- | A function for creating a value of the 'SqlBackend' type. You should prefer @@ -153,6 +157,7 @@ mkSqlBackend MkSqlBackendArgs {..} = , connPutManySql = Nothing , connUpsertSql = Nothing , connInsertManySql = Nothing + , connStatementMiddleware = const pure , .. } diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs index fa600dfda..e5709ae33 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -13,8 +13,8 @@ import Data.Map (Map) import Data.String import Data.Text (Text) import Database.Persist.Class.PersistStore +import Database.Persist.SqlBackend.StatementCache import Database.Persist.SqlBackend.Internal.Statement -import Database.Persist.SqlBackend.Internal.StatementCache import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.Types.Base @@ -35,7 +35,7 @@ data MkSqlBackendArgs = MkSqlBackendArgs , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult -- ^ This function generates the SQL and values necessary for -- performing an insert against the database. - , connStmtMap :: InternalStatementCache + , connStmtMap :: StatementCache -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () @@ -81,9 +81,6 @@ data MkSqlBackendArgs = MkSqlBackendArgs -- queries are the superior way to offer pagination. , connLogFunc :: LogFunc -- ^ A log function for the 'SqlBackend' to use. - , connStatementMiddleware :: Text -> Statement -> IO Statement - -- ^ Provide facilities for injecting middleware into statements - -- to allow for instrumenting queries. } type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () diff --git a/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs b/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs index edb47cd9b..f25ac0926 100644 --- a/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs +++ b/persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs @@ -1,54 +1,23 @@ -module Database.Persist.SqlBackend.Internal.StatementCache - ( StatementCache(..) - , InternalStatementCache - , makeSimpleStatementCache - , internalizeStatementCache - ) where +module Database.Persist.SqlBackend.Internal.StatementCache where -import Data.Foldable -import Data.IORef -import qualified Data.Map as Map import Data.Text (Text) import Database.Persist.SqlBackend.Internal.Statement -class StatementCache c where - statementCacheLookup :: c -> Text -> IO (Maybe Statement) - statementCacheInsert :: c -> Text -> Statement -> IO () - statementCacheClear :: c -> IO () - statementCacheSize :: c -> IO Int - -data InternalStatementCache = InternalStatementCache - { _statementCacheLookup :: Text -> IO (Maybe Statement) - , _statementCacheInsert :: Text -> Statement -> IO () - , _statementCacheClear :: IO () - , _statementCacheSize :: IO Int +-- | A statement cache used to lookup statements that have already been prepared +-- for a given query. +-- +-- @since 2.13.0 +data StatementCache = StatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + , statementCacheClear :: IO () + , statementCacheSize :: IO Int } -instance StatementCache InternalStatementCache where - statementCacheLookup = _statementCacheLookup - statementCacheInsert = _statementCacheInsert - statementCacheClear = _statementCacheClear - statementCacheSize = _statementCacheSize - - -internalizeStatementCache :: StatementCache c => c -> InternalStatementCache -internalizeStatementCache c = InternalStatementCache - { _statementCacheLookup = statementCacheLookup c - , _statementCacheInsert = statementCacheInsert c - , _statementCacheClear = statementCacheClear c - , _statementCacheSize = statementCacheSize c - } - -makeSimpleStatementCache :: IO InternalStatementCache -makeSimpleStatementCache = do - stmtMap <- newIORef Map.empty - pure $ InternalStatementCache - { _statementCacheLookup = \sql -> Map.lookup sql <$> readIORef stmtMap - , _statementCacheInsert = \sql stmt -> - modifyIORef' stmtMap (Map.insert sql stmt) - , _statementCacheClear = do - oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) - traverse_ stmtFinalize oldStatements - , _statementCacheSize = Map.size <$> readIORef stmtMap - } +newtype StatementCacheKey = StatementCacheKey { cacheKey :: Text } +-- Wrapping around this to allow for more efficient keying mechanisms +-- in the future, perhaps. +-- | Construct a `StatementCacheKey` from a raw SQL query. +mkCacheKeyFromQuery :: Text -> StatementCacheKey +mkCacheKeyFromQuery = StatementCacheKey diff --git a/persistent/Database/Persist/SqlBackend/StatementCache.hs b/persistent/Database/Persist/SqlBackend/StatementCache.hs new file mode 100644 index 000000000..c04a4a55b --- /dev/null +++ b/persistent/Database/Persist/SqlBackend/StatementCache.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Persist.SqlBackend.StatementCache + ( StatementCache + , StatementCacheKey + , mkCacheKeyFromQuery + , statementCacheKeyQuery + , MkStatementCache(..) + , mkSimpleStatementCache + , mkStatementCache + ) where + +import Data.Foldable +import Data.IORef +import qualified Data.Map as Map +import Data.Text (Text) +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.StatementCache + + +-- | Get the SQL query for the given cache key +-- +-- @since 2.13.0 +statementCacheKeyQuery :: StatementCacheKey -> Text +statementCacheKeyQuery = cacheKey + +-- | Configuration parameters for creating a custom statement cache +-- +-- @since 2.13.0 +data MkStatementCache = MkStatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + -- ^ Retrieve a statement from the cache, or return nothing if it is not found. + -- + -- @since 2.13.0 + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + -- ^ Put a new statement into the cache. An immediate lookup of + -- the statement MUST return the inserted statement for the given + -- cache key. Dependening on the implementation, the statement cache MAY + -- choose to evict other statements from the cache within this function. + -- + -- @since 2.13.0 + , statementCacheClear :: IO () + -- ^ Remove all statements from the cache. Implementations of this + -- should be sure to call `stmtFinalize` on all statements removed + -- from the cache. + -- + -- @since 2.13.0 + , statementCacheSize :: IO Int + -- ^ Get the current size of the cache. + -- + -- @since 2.13.0 + } + + +-- | Make a simple statement cache that will cache statements if they are not currently cached. +-- +-- @since 2.13.0 +mkSimpleStatementCache :: IO MkStatementCache +mkSimpleStatementCache = do + stmtMap <- newIORef Map.empty + pure $ MkStatementCache + { statementCacheLookup = \sql -> Map.lookup (cacheKey sql) <$> readIORef stmtMap + , statementCacheInsert = \sql stmt -> + modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) + , statementCacheClear = do + oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) + traverse_ stmtFinalize oldStatements + , statementCacheSize = Map.size <$> readIORef stmtMap + } + +-- | Create a statement cache. +-- +-- @since 2.13.0 +mkStatementCache :: MkStatementCache -> StatementCache +mkStatementCache MkStatementCache{..} = StatementCache { .. } diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index b47933a20..4be85286d 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -59,10 +59,12 @@ library Database.Persist.Sql.Types.Internal Database.Persist.SqlBackend + Database.Persist.SqlBackend.StatementCache Database.Persist.SqlBackend.Internal Database.Persist.SqlBackend.Internal.InsertSqlResult Database.Persist.SqlBackend.Internal.IsolationLevel Database.Persist.SqlBackend.Internal.Statement + Database.Persist.SqlBackend.Internal.StatementCache Database.Persist.SqlBackend.Internal.MkSqlBackend Database.Persist.Class.DeleteCascade From 82b090377973301679e50cdb74aa46759ff26035 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Thu, 8 Apr 2021 11:35:25 -0700 Subject: [PATCH 12/14] Patch up MySQL again --- persistent-mysql/Database/Persist/MySQL.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index cd38e7e15..4207db073 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -71,6 +71,7 @@ import System.Environment (getEnvironment) import Database.Persist.Sql import Database.Persist.SqlBackend +import Database.Persist.SqlBackend.StatementCache import Database.Persist.Sql.Types.Internal (makeIsolationLevelStatement) import qualified Database.Persist.Sql.Util as Util @@ -125,7 +126,7 @@ open' :: MySQL.ConnectInfo -> LogFunc -> IO SqlBackend open' ci logFunc = do conn <- MySQL.connect ci MySQLBase.autocommit conn False -- disable autocommit! - smap <- mkSimpleStatementCache + smap <- mkStatementCache <$> mkSimpleStatementCache return $ setConnPutManySql putManySql $ setConnRepsertManySql repsertManySql $ @@ -1242,7 +1243,7 @@ mockMigrate _connectInfo allDefs _getter val = do -- the actual database isn't already present in the system. mockMigration :: Migration -> IO () mockMigration mig = do - smap <- mkSimpleStatementCache + smap <- mkStatemeentCache <$> mkSimpleStatementCache let sqlbackend = mkSqlBackend MkSqlBackendArgs { connPrepare = \_ -> do From 84bd14585a7f846e00d7aeaff2590049bf15d535 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Thu, 8 Apr 2021 11:49:47 -0700 Subject: [PATCH 13/14] Remove connStatementMiddleware from MySQL internals --- persistent-mysql/Database/Persist/MySQL.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 4207db073..0a2c10cf7 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -1267,7 +1267,6 @@ mockMigration mig = do , connRDBMS = undefined , connLimitOffset = undefined , connLogFunc = undefined - , connStatementMiddleware = const pure } result = runReaderT . runWriterT . runWriterT $ mig resp <- result sqlbackend From 589d592c64271f2b8a2183ab4cbed2ac32f3381f Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Thu, 8 Apr 2021 13:54:53 -0700 Subject: [PATCH 14/14] Do away with internal uses of IsPersistBackend and deprecate it. --- persistent/Database/Persist/Class/PersistStore.hs | 1 + persistent/Database/Persist/Sql/Class.hs | 5 ++--- persistent/Database/Persist/Sql/Types/Internal.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent/Database/Persist/Class/PersistStore.hs b/persistent/Database/Persist/Class/PersistStore.hs index b721d1f7f..b7b35ffff 100644 --- a/persistent/Database/Persist/Class/PersistStore.hs +++ b/persistent/Database/Persist/Class/PersistStore.hs @@ -57,6 +57,7 @@ withBaseBackend = withReaderT persistBackend -- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@. -- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@. +{-# DEPRECATED IsPersistBackend "Use BackendCompatible" #-} class (HasPersistBackend backend) => IsPersistBackend backend where -- | This function is how we actually construct and tag a backend as having read or write capabilities. -- It should be used carefully and only when actually constructing a @backend@. Careless use allows us diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 9a4aa9a71..d2dc76d8c 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -57,7 +57,7 @@ instance PersistField a => RawSql (Single a) where rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." instance - (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => + (PersistEntity a, PersistEntityBackend a ~ backend) => RawSql (Key a) where rawSqlCols _ key = (length $ keyToValues key, []) rawSqlColCountReason key = "The primary key is composed of " @@ -66,7 +66,7 @@ instance rawSqlProcessRow = keyFromValues instance - (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => + (PersistEntity record, PersistEntityBackend record ~ backend) => RawSql (Entity record) where rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) where @@ -147,7 +147,6 @@ instance ( PersistEntity record , KnownSymbol prefix , PersistEntityBackend record ~ backend - , IsPersistBackend backend ) => RawSql (EntityWithPrefix prefix record) where rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) diff --git a/persistent/Database/Persist/Sql/Types/Internal.hs b/persistent/Database/Persist/Sql/Types/Internal.hs index 34feca045..b00f918f7 100644 --- a/persistent/Database/Persist/Sql/Types/Internal.hs +++ b/persistent/Database/Persist/Sql/Types/Internal.hs @@ -107,4 +107,4 @@ type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backe type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a -- | A backend which is a wrapper around @SqlBackend@. -type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend) +type IsSqlBackend backend = (BackendCompatible SqlBackend backend)