diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index 77741eb3c..2c3193e34 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | Use persistent-mongodb the same way you would use other persistent -- libraries and refer to the general persistent documentation. -- There are some new MongoDB specific filters under the filters section. @@ -1047,6 +1048,8 @@ instance DB.Val PersistValue where val (PersistRational _) = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend" val (PersistArray a) = DB.val $ PersistList a val (PersistDbSpecific _) = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend" + val (PersistLiteral _) = throw $ PersistMongoDBUnsupported "PersistLiteral not implemented for the MongoDB backend" + val (PersistLiteralEscaped _) = throw $ PersistMongoDBUnsupported "PersistLiteralEscaped not implemented for the MongoDB backend" cast' (DB.Float x) = Just (PersistDouble x) cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x cast' (DB.Int64 x) = Just $ PersistInt64 x diff --git a/persistent-mongoDB/test/EmbedTestMongo.hs b/persistent-mongoDB/test/EmbedTestMongo.hs index 688a53c8f..4a7216060 100644 --- a/persistent-mongoDB/test/EmbedTestMongo.hs +++ b/persistent-mongoDB/test/EmbedTestMongo.hs @@ -303,7 +303,7 @@ specs = describe "embedded entities" $ do it "can embed an Entity" $ db $ do let foo = ARecord "foo" bar = ARecord "bar" - _ <- insertMany [foo, bar] + insertMany_ [foo, bar] arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) [] length arecords @== 2 diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index e407910df..d3c54fa9a 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -1,10 +1,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | A MySQL backend for @persistent@. module Database.Persist.MySQL ( withMySQLPool @@ -64,7 +67,6 @@ import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T -import Text.Read (readMaybe) import System.Environment (getEnvironment) import Database.Persist.Sql @@ -240,6 +242,8 @@ instance MySQL.Param P where MySQL.Plain $ BBB.fromString $ show (fromRational r :: Pico) -- FIXME: Too Ambiguous, can not select precision without information about field render (P (PersistDbSpecific s)) = MySQL.Plain $ BBS.fromByteString s + render (P (PersistLiteral l)) = MySQL.Plain $ BBS.fromByteString l + render (P (PersistLiteralEscaped e)) = MySQL.Escape e render (P (PersistArray a)) = MySQL.render (P (PersistList a)) render (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a MySQL value" @@ -313,7 +317,7 @@ getGetter field = go (MySQLBase.fieldType field) -- Conversion using PersistDbSpecific go MySQLBase.Geometry _ _ = \_ m -> case m of - Just g -> PersistDbSpecific g + Just g -> PersistLiteral g Nothing -> error "Unexpected null in database specific value" -- Unsupported go other _ _ = error $ "MySQL.getGetter: type " ++ @@ -481,12 +485,13 @@ findMaxLenOfColumn allDefs name col = -- | Find out the maxlen of a field findMaxLenOfField :: FieldDef -> Maybe Integer -findMaxLenOfField fieldDef = do - maxLenAttr <- listToMaybe - . mapMaybe (T.stripPrefix "maxlen=" . T.toLower) +findMaxLenOfField fieldDef = + listToMaybe + . mapMaybe (\case + FieldAttrMaxlen x -> Just x + _ -> Nothing) . fieldAttrs $ fieldDef - readMaybe $ T.unpack maxLenAttr -- | Helper for 'AddReference' that finds out the which primary key columns to reference. addReference @@ -517,6 +522,8 @@ data AlterColumn = Change Column | Drop | Default String | NoDefault + | Gen SqlType (Maybe Integer) String + | NoGen SqlType (Maybe Integer) | Update' String -- | See the definition of the 'showAlter' function to see how these fields are used. | AddReference @@ -565,7 +572,8 @@ getColumns connectInfo getter def cols = do , "CHARACTER_MAXIMUM_LENGTH, " , "NUMERIC_PRECISION, " , "NUMERIC_SCALE, " - , "COLUMN_DEFAULT " + , "COLUMN_DEFAULT, " + , "GENERATION_EXPRESSION " , "FROM INFORMATION_SCHEMA.COLUMNS " , "WHERE TABLE_SCHEMA = ? " , "AND TABLE_NAME = ? " @@ -635,13 +643,15 @@ getColumn connectInfo getter tname [ PersistText cname , colMaxLen , colPrecision , colScale - , default'] cRef = + , default' + , generated + ] cRef = fmap (either (Left . pack) Right) $ runExceptT $ do -- Default value default_ <- case default' of - PersistNull -> return Nothing + PersistNull -> return Nothing PersistText t -> return (Just t) PersistByteString bs -> case T.decodeUtf8' bs of @@ -650,12 +660,31 @@ getColumn connectInfo getter tname [ PersistText cname $ "Invalid default column: " ++ show default' ++ " (error: " ++ show exc ++ ")" - Right t -> + Right t -> return (Just t) _ -> fail $ "Invalid default column: " ++ show default' + generated_ <- + case generated of + PersistNull -> return Nothing + PersistText "" -> return Nothing + PersistByteString "" -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> + fail + $ "Invalid generated column: " + ++ show generated + ++ " (error: " ++ show exc ++ ")" + Right t -> + return (Just t) + _ -> + fail $ "Invalid generated column: " ++ show generated + ref <- getRef (crConstraintName <$> cRef) + let colMaxLen' = case colMaxLen of PersistInt64 l -> Just (fromIntegral l) @@ -666,13 +695,16 @@ getColumn connectInfo getter tname [ PersistText cname , ciNumericPrecision = colPrecision , ciNumericScale = colScale } + (typ, maxLen) <- parseColumnType dataType ci + -- Okay! return Column { cName = DBName $ cname , cNull = null_ == "YES" , cSqlType = typ , cDefault = default_ + , cGenerated = generated_ , cDefaultConstraintName = Nothing , cMaxLen = maxLen , cReference = ref @@ -821,7 +853,7 @@ getAlters allDefs edef (c1, u1) (c2, u2) = (col', ty, ml) --- | @findAlters newColumn oldColumns@ finds out what needs to be +-- | @findAlters x y newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. findAlters @@ -830,7 +862,7 @@ findAlters -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName maxLen ref) cols = +findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName maxLen ref) cols = case filter ((name ==) . cName) cols of -- new fkey that didn't exist before [] -> @@ -842,7 +874,7 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max cnstr = [addReference allDefs cname tname name (crFieldCascade cr)] in (map ((,) tname) (Add' col : cnstr), cols) - Column _ isNull' type_' def' _defConstraintName' maxLen' ref' : _ -> + Column _ isNull' type_' def' gen' _defConstraintName' maxLen' ref' : _ -> let -- Foreign key refDrop = case (ref == ref', ref') of @@ -861,15 +893,25 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] | otherwise = [(name, Change col)] + -- Default value -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields - modDef | def == def' = [] - | otherwise = - case def of - Nothing -> [(name, NoDefault)] - Just s -> if T.toUpper s == "NULL" then [] - else [(name, Default $ T.unpack s)] - in ( refDrop ++ modType ++ modDef ++ refAdd + modDef = + if def == def' then [] + else case def of + Nothing -> [(name, NoDefault)] + Just s -> + if T.toUpper s == "NULL" then [] + else [(name, Default $ T.unpack s)] + + -- Does the generated value need to change? + modGen = + if gen == gen' then [] + else case gen of + Nothing -> [(name, NoGen type_ maxLen)] + Just genExpr -> [(name, Gen type_ maxLen $ T.unpack genExpr)] + + in ( refDrop ++ modType ++ modDef ++ modGen ++ refAdd , filter ((name /=) . cName) cols ) @@ -882,11 +924,16 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max -- | Prints the part of a @CREATE TABLE@ statement about a given -- column. showColumn :: Column -> String -showColumn (Column n nu t def _defConstraintName maxLen ref) = concat +showColumn (Column n nu t def gen _defConstraintName maxLen ref) = concat [ escapeDBName n , " " , showSqlType t maxLen True , " " + , case gen of + Nothing -> "" + Just genExpr -> + if T.toUpper genExpr == "NULL" then "" + else " GENERATED ALWAYS AS (" <> T.unpack genExpr <> ") STORED " , if nu then "NULL" else "NOT NULL" , case def of Nothing -> "" @@ -958,14 +1005,14 @@ showAlterTable table (DropUniqueConstraint cname) = concat -- | Render an action that must be done on a column. showAlter :: DBName -> AlterColumn' -> String -showAlter table (oldName, Change (Column n nu t def defConstraintName maxLen _ref)) = +showAlter table (oldName, Change (Column n nu t def gen defConstraintName maxLen _ref)) = concat [ "ALTER TABLE " , escapeDBName table , " CHANGE " , escapeDBName oldName , " " - , showColumn (Column n nu t def defConstraintName maxLen Nothing) + , showColumn (Column n nu t def gen defConstraintName maxLen Nothing) ] showAlter table (_, Add' col) = concat @@ -998,6 +1045,27 @@ showAlter table (n, NoDefault) = , escapeDBName n , " DROP DEFAULT" ] +showAlter table (col, Gen typ len expr) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " MODIFY COLUMN " + , escapeDBName col + , " " + , showSqlType typ len True + , " GENERATED ALWAYS AS (" + , expr + , ") STORED" + ] +showAlter table (col, NoGen typ len) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " MODIFY COLUMN " + , escapeDBName col + , " " + , showSqlType typ len True + ] showAlter table (n, Update' s) = concat [ "UPDATE " diff --git a/persistent-mysql/test/CustomConstraintTest.hs b/persistent-mysql/test/CustomConstraintTest.hs index a16cb0a28..9ded31cb6 100644 --- a/persistent-mysql/test/CustomConstraintTest.hs +++ b/persistent-mysql/test/CustomConstraintTest.hs @@ -44,7 +44,7 @@ specs runDb = do describe "custom constraint used in migration" $ before_ (runDb $ void $ runMigrationSilent customConstraintMigrate) $ after_ (runDb clean) $ do it "custom constraint is actually created" $ runDb $ do - runMigrationSilent customConstraintMigrate -- run a second time to ensure the constraint isn't dropped + void $ runMigrationSilent customConstraintMigrate -- run a second time to ensure the constraint isn't dropped let query = T.concat ["SELECT COUNT(*) " ,"FROM information_schema.key_column_usage " ,"WHERE ordinal_position=1 " @@ -53,12 +53,14 @@ specs runDb = do ,"AND table_name=? " ,"AND column_name=? " ,"AND constraint_name=?"] - [Single exists] <- rawSql query [PersistText "custom_constraint1" - ,PersistText "id" - ,PersistText "custom_constraint2" - ,PersistText "cc_id" - ,PersistText "custom_constraint"] - liftIO $ 1 @?= (exists :: Int) + [Single exists_] <- rawSql query + [ PersistText "custom_constraint1" + , PersistText "id" + , PersistText "custom_constraint2" + , PersistText "cc_id" + , PersistText "custom_constraint" + ] + liftIO $ 1 @?= (exists_ :: Int) it "allows multiple constraints on a single column" $ runDb $ do -- Here we add another foreign key on the same column where the diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index 7ae5e51f6..595d13b60 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -42,7 +42,7 @@ specs = describe "DuplicateKeyUpdate" $ do it "performs only updates given if record already exists" $ db $ do deleteWhere ([] :: [Filter Item]) let newDescription = "I am a new description" - _ <- insert item1 + insert_ item1 insertOnDuplicateKeyUpdate (Item "item1" "i am inserted description" (Just 1) (Just 2)) [ItemDescription =. newDescription] diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index e23af5689..56e165d8f 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -52,6 +52,7 @@ import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest import qualified LongIdentifierTest +import qualified GeneratedColumnTestSQL import qualified ForeignKey type Tuple a b = (a, b) @@ -199,6 +200,7 @@ main = do -- TODO: implement automatic truncation for too long foreign keys, so we can run this test. xdescribe "The migration for this test currently fails because of MySQL's 64 character limit for identifiers. See https://github.com/yesodweb/persistent/issues/1000 for details" $ LongIdentifierTest.specsWith db + GeneratedColumnTestSQL.specsWith db roundFn :: RealFrac a => a -> Integer roundFn = round diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index b9ebfc9dd..e346b45c5 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | A postgresql backend for persistent. module Database.Persist.Postgresql @@ -31,8 +33,6 @@ module Database.Persist.Postgresql , defaultPostgresConfHooks ) where -import qualified Debug.Trace as Debug - import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Simple as PG @@ -44,7 +44,6 @@ import qualified Database.PostgreSQL.Simple.Types as PG import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import Database.PostgreSQL.Simple.Ok (Ok (..)) -import Data.Foldable import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad @@ -62,6 +61,7 @@ import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Bits ((.&.)) import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Conduit @@ -522,6 +522,8 @@ instance PGTF.ToField P where toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m toField (P (PersistDbSpecific s)) = PGTF.toField (Unknown s) + toField (P (PersistLiteral l)) = PGTF.toField (UnknownLiteral l) + toField (P (PersistLiteralEscaped e)) = PGTF.toField (Unknown e) toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" @@ -613,8 +615,9 @@ fromPersistValueError haskellType databaseType received = T.concat ] instance PersistField PgInterval where - toPersistValue = PersistDbSpecific . pgIntervalToBs - fromPersistValue x@(PersistDbSpecific bs) = + toPersistValue = PersistLiteralEscaped . pgIntervalToBs + fromPersistValue (PersistDbSpecific bs) = fromPersistValue (PersistLiteralEscaped bs) + fromPersistValue x@(PersistLiteralEscaped bs) = case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of Left _ -> Left $ fromPersistValueError "PgInterval" "Interval" x Right i -> Right $ PgInterval i @@ -635,6 +638,19 @@ instance PGFF.FromField Unknown where instance PGTF.ToField Unknown where toField (Unknown a) = PGTF.Escape a +newtype UnknownLiteral = UnknownLiteral { unUnknownLiteral :: ByteString } + deriving (Eq, Show, Read, Ord, Typeable) + +instance PGFF.FromField UnknownLiteral where + fromField f mdata = + case mdata of + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField UnknownLiteral" + Just dat -> return (UnknownLiteral dat) + +instance PGTF.ToField UnknownLiteral where + toField (UnknownLiteral a) = PGTF.Plain $ BB.byteString a + + type Getter a = PGFF.FieldParser a convertPV :: PGFF.FromField a => (a -> b) -> Getter b @@ -660,7 +676,7 @@ builtinGetters = I.fromList , (k PS.time, convertPV PersistTimeOfDay) , (k PS.timestamp, convertPV (PersistUTCTime. localTimeToUTC utc)) , (k PS.timestamptz, convertPV PersistUTCTime) - , (k PS.interval, convertPV (PersistDbSpecific . pgIntervalToBs)) + , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) , (k PS.bit, convertPV PersistInt64) , (k PS.varbit, convertPV PersistInt64) , (k PS.numeric, convertPV PersistRational) @@ -691,12 +707,12 @@ builtinGetters = I.fromList , (1183, listOf PersistTimeOfDay) , (1115, listOf PersistUTCTime) , (1185, listOf PersistUTCTime) - , (1187, listOf (PersistDbSpecific . pgIntervalToBs)) + , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) , (1561, listOf PersistInt64) , (1563, listOf PersistInt64) , (1231, listOf PersistRational) -- no array(void) type - , (2951, listOf (PersistDbSpecific . unUnknown)) + , (2951, listOf (PersistLiteralEscaped . unUnknown)) , (199, listOf (PersistByteString . unUnknown)) , (3807, listOf (PersistByteString . unUnknown)) -- no array(unknown) either @@ -714,7 +730,7 @@ builtinGetters = I.fromList getGetter :: PG.Connection -> PG.Oid -> Getter PersistValue getGetter _conn oid = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters - where defaultGetter = convertPV (PersistDbSpecific . unUnknown) + where defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x @@ -770,7 +786,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do -- Check for table existence if there are no columns, workaround -- for https://github.com/yesodweb/persistent/issues/152 - createText newcols fdefs udspair = + createText newcols fdefs_ udspair = (addTable newcols entity) : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> @@ -781,7 +797,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do getAddReference allDefs entity cName =<< cReference ) newcols - foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs + foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs_ mkForeignAlt :: EntityDef @@ -789,12 +805,12 @@ mkForeignAlt -> Maybe AlterDB mkForeignAlt entity fdef = do pure $ AlterColumn - tableName + tableName_ ( foreignRefTableDBName fdef , addReference ) where - tableName = entityDB entity + tableName_ = entityDB entity addReference = AddReference constraintName @@ -890,6 +906,7 @@ getColumns getter def cols = do , ",is_nullable " , ",COALESCE(domain_name, udt_name)" -- See DOMAINS below , ",column_default " + , ",generation_expression " , ",numeric_precision " , ",numeric_scale " , ",character_maximum_length " @@ -965,7 +982,7 @@ getColumns getter def cols = do -- list. safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) - = any (elem "SafeToRemove" . fieldAttrs) + = any (elem FieldAttrSafeToRemove . fieldAttrs) $ filter ((== DBName colName) . fieldDB) $ keyAndEntityFields def @@ -1010,8 +1027,16 @@ getColumn -> [PersistValue] -> Maybe (DBName, DBName) -> IO (Either Text Column) -getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = runExceptT $ do - d'' <- +getColumn getter tableName' [ PersistText columnName + , PersistText isNullable + , PersistText typeName + , defaultValue + , generationExpression + , numericPrecision + , numericScale + , maxlen + ] refName_ = runExceptT $ do + defaultValue' <- case defaultValue of PersistNull -> pure Nothing @@ -1020,30 +1045,47 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per _ -> throwError $ T.pack $ "Invalid default column: " ++ show defaultValue + generationExpression' <- + case generationExpression of + PersistNull -> + pure Nothing + PersistText t -> + pure $ Just t + _ -> + throwError $ T.pack $ "Invalid generated column: " ++ show generationExpression + let typeStr = case maxlen of PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] _ -> typeName + t <- getType typeStr + let cname = DBName columnName - ref <- lift $ fmap join $ traverse (getRef cname) refName + + ref <- lift $ fmap join $ traverse (getRef cname) refName_ + return Column { cName = cname , cNull = isNullable == "YES" , cSqlType = t - , cDefault = fmap stripSuffixes d'' + , cDefault = fmap stripSuffixes defaultValue' + , cGenerated = fmap stripSuffixes generationExpression' , cDefaultConstraintName = Nothing , cMaxLen = Nothing , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref } + where + mkCascade updText delText = FieldCascade { fcOnUpdate = parseCascade updText , fcOnDelete = parseCascade delText } + parseCascade txt = case txt of "NO ACTION" -> @@ -1058,6 +1100,7 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per Just Restrict _ -> error $ "Unexpected value in parseCascade: " <> show txt + stripSuffixes t = loop' [ "::character varying" @@ -1131,6 +1174,7 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per getNumeric (PersistInt64 a) (PersistInt64 b) = pure $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric PersistNull PersistNull = throwError $ T.concat [ "No precision and scale were specified for the column: " , columnName @@ -1140,6 +1184,7 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per , " which is probably not what you intended." , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] + getNumeric a b = throwError $ T.concat [ "Can not get numeric field precision for the column: " , columnName @@ -1153,6 +1198,7 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per , ", respectively." , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] + getColumn _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName @@ -1170,11 +1216,11 @@ findAlters -- ^ The column that we're searching for potential alterations for. -> [Column] -> ([AlterColumn'], [Column]) -findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = +findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName _maxLen ref) cols = case List.find (\c -> cName c == name) cols of Nothing -> ([(name, Add' col)], cols) - Just (Column _oldName isNull' sqltype' def' _defConstraintName' _maxLen' ref') -> + Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> let refDrop Nothing = [] refDrop (Just ColumnReference {crConstraintName=cname}) = [(name, DropReference cname)] @@ -1261,7 +1307,7 @@ getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crCons return $ Util.dbIdColumnsEsc escape entDef showColumn :: Column -> Text -showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat +showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat [ escape n , " " , showSqlType sqlType' @@ -1270,6 +1316,9 @@ showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat , case def of Nothing -> "" Just s -> " DEFAULT " <> s + , case gen of + Nothing -> "" + Just s -> " GENERATED ALWAYS AS (" <> s <> ") STORED" ] showSqlType :: SqlType -> Text diff --git a/persistent-postgresql/Database/Persist/Postgresql/JSON.hs b/persistent-postgresql/Database/Persist/Postgresql/JSON.hs index 4a9e032d1..d579f634c 100644 --- a/persistent-postgresql/Database/Persist/Postgresql/JSON.hs +++ b/persistent-postgresql/Database/Persist/Postgresql/JSON.hs @@ -333,7 +333,7 @@ instance PersistFieldSql Value where -- but needs testing/profiling before changing it. -- (When entering into the DB the type isn't as important as fromPersistValue) toPersistValueJsonB :: ToJSON a => a -> PersistValue -toPersistValueJsonB = PersistDbSpecific . BSL.toStrict . encode +toPersistValueJsonB = PersistLiteralEscaped . BSL.toStrict . encode fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a fromPersistValueJsonB (PersistText t) = diff --git a/persistent-postgresql/test/CustomConstraintTest.hs b/persistent-postgresql/test/CustomConstraintTest.hs index 5fec69baa..a21218161 100644 --- a/persistent-postgresql/test/CustomConstraintTest.hs +++ b/persistent-postgresql/test/CustomConstraintTest.hs @@ -50,12 +50,12 @@ specs = do ,"AND kcu.table_name=? " ,"AND kcu.column_name=? " ,"AND tc.constraint_name=?"] - [Single exists] <- rawSql query [PersistText "custom_constraint1" + [Single exists_] <- rawSql query [PersistText "custom_constraint1" ,PersistText "id" ,PersistText "custom_constraint2" ,PersistText "cc_id" ,PersistText "custom_constraint"] - liftIO $ 1 @?= (exists :: Int) + liftIO $ 1 @?= (exists_ :: Int) it "allows multiple constraints on a single column" $ runConnAssert $ do void $ runMigrationSilent customConstraintMigrate diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index eedc620f7..6c0c47ee6 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -54,6 +54,7 @@ import qualified UpsertTest import qualified CustomConstraintTest import qualified LongIdentifierTest import qualified PgIntervalTest +import qualified GeneratedColumnTestSQL type Tuple = (,) @@ -196,3 +197,4 @@ main = do CustomConstraintTest.specs PgIntervalTest.specs ArrayAggTest.specs + GeneratedColumnTestSQL.specsWith runConnAssert diff --git a/persistent-redis/Database/Persist/Redis/Parser.hs b/persistent-redis/Database/Persist/Redis/Parser.hs index f75490ac3..5e74b976c 100644 --- a/persistent-redis/Database/Persist/Redis/Parser.hs +++ b/persistent-redis/Database/Persist/Redis/Parser.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' module Database.Persist.Redis.Parser ( redisToPerisistValues , toValue @@ -128,6 +129,8 @@ instance Binary BinPersistValue where put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray" put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific" + put (BinPersistValue (PersistLiteral _)) = throw $ NotSupportedValueType "PersistLiteral" + put (BinPersistValue (PersistLiteralEscaped _)) = throw $ NotSupportedValueType "PersistLiteralEscaped" put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId" get = do @@ -160,4 +163,4 @@ castOne :: B.ByteString -> PersistValue castOne = unBinPersistValue . Q.decode . L.fromStrict redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue] -redisToPerisistValues = map (castOne . snd) \ No newline at end of file +redisToPerisistValues = map (castOne . snd) diff --git a/persistent-redis/Database/Persist/Redis/Store.hs b/persistent-redis/Database/Persist/Redis/Store.hs index ce842cbb1..2a8abcea9 100644 --- a/persistent-redis/Database/Persist/Redis/Store.hs +++ b/persistent-redis/Database/Persist/Redis/Store.hs @@ -65,7 +65,7 @@ instance PersistStoreWrite R.Connection where keyId <- execRedisT $ createKey val let textKey = toKeyText val keyId key <- liftIO $ toKey textKey - _ <- insertKey key val + insertKey key val return key insertKey k val = do diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 92b27186e..7eeeb6c08 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -313,43 +314,68 @@ prepare' conn sql = do , stmtQuery = withStmt' conn stmt } +-- TODO: Persistent support for Sqlite generated columns is currently broken. +-- In Postgresql and MySQL, it is valid to make a perpared insert statement that +-- includes a generated column so long as when you execute that statement, +-- you use the literal 'DEFAULT' keyword for the value of the generated column, +-- and so this is currently what Persistent does. However, Sqlite makes it +-- an error to create a prepared insert statement that includes a generated +-- column. As a result, we ignore the 'generated=' attribute for Sqlite. To +-- support generated columns, we need to: (1) remove the generated columns +-- from the prepared statement (done, but commented out); and (2) also +-- remove the /values/ of the generated columns at the point the prepared +-- statement is executed (not done). insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = - case entityPrimary ent of - Just _ -> - ISRManyKeys sql vals - where sql = T.concat - [ "INSERT INTO " - , escape $ entityDB ent - , "(" - , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent - , ") VALUES(" - , T.intercalate "," (map (const "?") $ entityFields ent) - , ")" - ] - Nothing -> - ISRInsertGet ins sel - where - sel = T.concat - [ "SELECT " - , escape $ fieldDB (entityId ent) - , " FROM " - , escape $ entityDB ent - , " WHERE _ROWID_=last_insert_rowid()" - ] - ins = T.concat - [ "INSERT INTO " - , escape $ entityDB ent - , if null (entityFields ent) - then " VALUES(null)" - else T.concat - [ "(" - , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent - , ") VALUES(" - , T.intercalate "," (map (const "?") $ entityFields ent) - , ")" - ] - ] + case entityPrimary ent of + Just _ -> + ISRManyKeys sql vals + where sql = T.concat + [ "INSERT INTO " + , escape $ entityDB ent + , "(" + , T.intercalate "," $ map (escape . fieldDB) cols + , ") VALUES(" + , T.intercalate "," (map (const "?") cols) + , ")" + ] + Nothing -> + ISRInsertGet ins sel + where + sel = T.concat + [ "SELECT " + , escape $ fieldDB (entityId ent) + , " FROM " + , escape $ entityDB ent + , " WHERE _ROWID_=last_insert_rowid()" + ] + ins = T.concat + [ "INSERT INTO " + , escape $ entityDB ent + , if null cols + then " VALUES(null)" + else T.concat + [ "(" + , T.intercalate "," $ map (escape . fieldDB) $ cols + , ") VALUES(" + , T.intercalate "," (map (const "?") cols) + , ")" + ] + ] + where + cols = entityFields ent + -- TODO: Sqlite generated columns + -- notGenerated = + -- null + -- . find (\case + -- FieldAttrGenerated{} -> True + -- _ -> False + -- ) + -- . fieldAttrs + -- cols = + -- filter notGenerated $ entityFields ent + -- vals' = + -- filter notGenerated $ vals execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do @@ -469,7 +495,7 @@ mockMigration mig = do -- list. safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) - = any (elem "SafeToRemove" . fieldAttrs) + = any (elem FieldAttrSafeToRemove . fieldAttrs) $ filter ((== DBName colName) . fieldDB) $ entityFields def @@ -528,40 +554,40 @@ getCopyTable allDefs getter def = do mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text mkCreateTable isTemp entity (cols, uniqs, fdefs) = - case entityPrimary entity of - Just pdef -> - T.concat + T.concat (header <> columns <> footer) + where + header = [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE " , escape $ entityDB entity , "(" - , T.drop 1 $ T.concat $ map (sqlColumn isTemp) cols - , ", PRIMARY KEY " - , "(" - , T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef - , ")" - , T.concat $ map sqlUnique uniqs - , T.concat $ map sqlForeign fdefs - , ")" ] - Nothing -> T.concat - [ "CREATE" - , if isTemp then " TEMP" else "" - , " TABLE " - , escape $ entityDB entity - , "(" - , escape $ fieldDB (entityId entity) - , " " - , showSqlType $ fieldSqlType $ entityId entity - , " PRIMARY KEY" - , mayDefault $ defaultAttribute $ fieldAttrs $ entityId entity - , T.concat $ map (sqlColumn isTemp) nonIdCols - , T.concat $ map sqlUnique uniqs + + footer = + [ T.concat $ map sqlUnique uniqs , T.concat $ map sqlForeign fdefs , ")" ] - where + + columns = case entityPrimary entity of + Just pdef -> + [ T.drop 1 $ T.concat $ map (sqlColumn isTemp) cols + , ", PRIMARY KEY " + , "(" + , T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef + , ")" + ] + + Nothing -> + [ escape $ fieldDB (entityId entity) + , " " + , showSqlType $ fieldSqlType $ entityId entity + , " PRIMARY KEY" + , mayDefault $ defaultAttribute $ fieldAttrs $ entityId entity + , T.concat $ map (sqlColumn isTemp) nonIdCols + ] + nonIdCols = filter (\c -> cName c /= fieldDB (entityId entity)) cols mayDefault :: Maybe Text -> Text @@ -569,14 +595,21 @@ mayDefault def = case def of Nothing -> "" Just d -> " DEFAULT " <> d +-- TODO: Sqlite generated columns +-- mayGenerated :: Maybe Text -> Text +-- mayGenerated gen = case gen of +-- Nothing -> "" +-- Just g -> " GENERATED ALWAYS AS (" <> g <> ") STORED" + sqlColumn :: Bool -> Column -> Text -sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat +sqlColumn noRef (Column name isNull typ def _gen _cn _maxLen ref) = T.concat [ "," , escape name , " " , showSqlType typ , if isNull then " NULL" else " NOT NULL" , mayDefault def + -- , mayGenerated gen , case ref of Nothing -> "" Just ColumnReference {crTableName=table, crFieldCascade=cascadeOpts} -> diff --git a/persistent-sqlite/Database/Sqlite.hs b/persistent-sqlite/Database/Sqlite.hs index c0c9bf0a4..7da0f4268 100644 --- a/persistent-sqlite/Database/Sqlite.hs +++ b/persistent-sqlite/Database/Sqlite.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | A port of the direct-sqlite package for dealing directly with -- 'PersistValue's. module Database.Sqlite ( @@ -470,6 +471,10 @@ bind statement sqlData = do PersistDbSpecific s -> bindText statement parameterIndex $ decodeUtf8With lenientDecode s PersistArray a -> bindText statement parameterIndex $ listToJSON a -- copy of PersistList's definition PersistObjectId _ -> P.error "Refusing to serialize a PersistObjectId to a SQLite value" + + -- I know one of these is broken, but the docs for `sqlite3_bind_text` aren't very illuminating. + PersistLiteral l -> bindText statement parameterIndex $ decodeUtf8With lenientDecode l + PersistLiteralEscaped e -> bindText statement parameterIndex $ decodeUtf8With lenientDecode e ) $ zip [1..] sqlData return () diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 219fa11b3..dfe47b801 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -12,6 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} import SqliteInit @@ -32,6 +33,7 @@ import qualified MpsCustomPrefixTest import qualified MigrationColumnLengthTest import qualified MigrationOnlyTest import qualified PersistentTest +import qualified GeneratedColumnTestSQL import qualified PersistUniqueTest import qualified PrimaryTest import qualified RawSqlTest @@ -218,14 +220,16 @@ main = do TransactionLevelTest.specsWith db MigrationTest.specsWith db LongIdentifierTest.specsWith db + xdescribe "SQLite doesn't work, see PR #1122 for discussion" $ do + GeneratedColumnTestSQL.specsWith db it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - runMigrationSilent migrateAll - _ <- insert . Test $ read "2014-11-30 05:15:25.123Z" + void $ runMigrationSilent migrateAll + insert_ . Test $ read "2014-11-30 05:15:25.123Z" [Single x] <- rawSql "select strftime('%s%f',time) from test" [] liftIO $ x `shouldBe` Just ("141732452525.123" :: String) it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - runMigrationSilent migrateAll + void $ runMigrationSilent migrateAll now <- liftIO getCurrentTime tid <- insert $ Test now Just (Test now') <- get tid @@ -236,19 +240,19 @@ main = do Sqlite.close conn return () it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - runMigrationSilent migrateAll + void $ runMigrationSilent migrateAll insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z") it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - runMigrationSilent compositeSetup - runMigrationSilent compositeMigrateTest + void $ runMigrationSilent compositeSetup + void $ runMigrationSilent compositeMigrateTest pure () it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do - runMigrationSilent testMigrate + void $ runMigrationSilent testMigrate let catcher :: forall m. Monad m => SomeException -> m () catcher _ = return () - _ <- insert $ Person "A" 0 Nothing - _ <- insert_ (Person "A" 1 Nothing) `catch` catcher - _ <- insert $ Person "B" 0 Nothing + insert_ $ Person "A" 0 Nothing + insert_ (Person "A" 1 Nothing) `catch` catcher + insert_ $ Person "B" 0 Nothing return () diff --git a/persistent-sqlite/test1.hs b/persistent-sqlite/test1.hs index ccfa5cb8e..c1e62e8f3 100644 --- a/persistent-sqlite/test1.hs +++ b/persistent-sqlite/test1.hs @@ -45,7 +45,7 @@ go = do p3 <- selectList [PersonNameEq "Michael"] [] 0 0 liftIO $ print p3 - _ <- insert $ Person "Michael2" 27 Nothing + insert_ $ Person "Michael2" 27 Nothing deleteWhere [PersonNameEq "Michael2"] p4 <- selectList [PersonAgeLt 28] [] 0 0 liftIO $ print p4 @@ -59,11 +59,11 @@ go = do if fmap personAge p6 /= Just 29 then error "bug 57" else return () liftIO $ print p6 - _ <- insert $ Person "Eliezer" 2 $ Just "blue" + insert_ $ Person "Eliezer" 2 $ Just "blue" p7 <- selectList [] [PersonAgeAsc] 0 0 liftIO $ print p7 - _ <- insert $ Person "Abe" 30 $ Just "black" + insert_ $ Person "Abe" 30 $ Just "black" p8 <- selectList [PersonAgeLt 30] [PersonNameDesc] 0 0 liftIO $ print p8 @@ -92,7 +92,7 @@ go = do plast <- get pid liftIO $ print plast - _ <- insert $ Person "Gavriella" 0 Nothing + insert_ $ Person "Gavriella" 0 Nothing x@(_, Person "Gavriella" 0 Nothing) <- insertBy $ Person "Gavriella" 1 $ Just "blue" liftIO $ print x @@ -104,7 +104,7 @@ go = do p15 <- selectList [PersonNameIn $ words "Michael Gavriella"] [] 0 0 liftIO $ print p15 - _ <- insert $ Person "Miriam" 23 $ Just "red" + insert_ $ Person "Miriam" 23 $ Just "red" p16 <- selectList [PersonColorNotIn [Nothing, Just "blue"]] [] 0 0 liftIO $ print p16 @@ -112,8 +112,8 @@ go = do liftIO $ print p17 deleteWhere ([] :: [Filter Null]) - _ <- insert $ Null $ Just 5 - _ <- insert $ Null Nothing + insert_ $ Null $ Just 5 + insert_ $ Null Nothing [(_, Null (Just 5))] <- selectList [NullFieldGt 4] [] 0 0 [] <- selectList [NullFieldGt 5] [] 0 0 [(_, Null (Just 5))] <- selectList [NullFieldEq $ Just 5] [] 0 0 @@ -128,7 +128,7 @@ go = do _ <- selectList ([] :: [Filter Person]) [] 0 10 deleteWhere ([] :: [Filter Table]) - _ <- insert $ Table "foo" - _ <- insert $ Table "bar" + insert_ $ Table "foo" + insert_ $ Table "bar" return () diff --git a/persistent-sqlite/test3.hs b/persistent-sqlite/test3.hs index 8c03a4bc8..b40bfbd22 100644 --- a/persistent-sqlite/test3.hs +++ b/persistent-sqlite/test3.hs @@ -43,7 +43,7 @@ go = do p3 <- select [PersonNameEq "Michael"] [] liftIO $ print p3 - _ <- insert $ Person "Michael2" 27 Nothing + insert_ $ Person "Michael2" 27 Nothing deleteWhere [PersonNameEq "Michael2"] p4 <- select [PersonAgeLt 28] [] liftIO $ print p4 diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 7938147c9..826ed959f 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -63,7 +63,6 @@ module Database.Persist.TH import Prelude hiding ((++), take, concat, splitAt, exp) -import Control.Applicative import Data.Either import Control.Monad import Data.Aeson @@ -85,7 +84,7 @@ import qualified Data.Map as M import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) import Data.Monoid ((<>), mappend, mconcat) import Data.Proxy (Proxy (Proxy)) -import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix) +import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE @@ -397,7 +396,7 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = maybe (defaultSqlTypeExp field) (SqlType' . SqlOther) - (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field) + (listToMaybe $ mapMaybe (\case {FieldAttrSqltype x -> Just x; _ -> Nothing}) $ fieldAttrs field) -- In the case of embedding, there won't be any datatype created yet. -- We just use SqlString, as the data will be serialized to JSON. @@ -464,8 +463,8 @@ fixEntityDef :: EntityDef -> EntityDef fixEntityDef ed = ed { entityFields = filter keepField $ entityFields ed } where - keepField fd = "MigrationOnly" `notElem` fieldAttrs fd && - "SafeToRemove" `notElem` fieldAttrs fd + keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd && + FieldAttrSafeToRemove `notElem` fieldAttrs fd -- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings @@ -1170,8 +1169,7 @@ mkEntity entityMap mps t = do case entityPrimary t of Just prim -> do recordName <- newName "record" - let fields = map fieldHaskell (compositeFields prim) - keyCon = keyConName t + let keyCon = keyConName t keyFields' = map (mkName . T.unpack . recName mps entName . fieldHaskell) (compositeFields prim) @@ -1742,7 +1740,7 @@ liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments) = ForeignRef refName _ft -> do ent <- M.lookup refName entityMap case fieldReference $ entityId ent of - fr@(ForeignRef targetName ft) -> + fr@(ForeignRef _ ft) -> Just (fr, lift $ SqlTypeExp ft) _ -> Nothing @@ -1753,6 +1751,8 @@ deriving instance Lift EntityDef deriving instance Lift FieldDef +deriving instance Lift FieldAttr + deriving instance Lift UniqueDef deriving instance Lift CompositeDef diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 344341dd1..0ab32c88a 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -39,6 +39,7 @@ library PersistentTest PersistentTestModels PersistentTestModelsImports + GeneratedColumnTestSQL PersistTestPetType PersistTestPetCollarType PersistUniqueTest diff --git a/persistent-test/src/CompositeTest.hs b/persistent-test/src/CompositeTest.hs index 2bfff4750..af8a77787 100644 --- a/persistent-test/src/CompositeTest.hs +++ b/persistent-test/src/CompositeTest.hs @@ -135,7 +135,7 @@ specsWith runDb = describe "composite" $ it "Extract Parent Foreign Key from Child value" $ runDb $ do kp1 <- insert p1 - _ <- insert p2 + insert_ p2 kc1 <- insert c1 mc <- get kc1 isJust mc @== True @@ -144,9 +144,9 @@ specsWith runDb = describe "composite" $ testChildFkparent c11 @== kp1 it "Validate Key contents" $ runDb $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 + insert_ p1 + insert_ p2 + insert_ p3 xs <- selectKeysList [] [Asc TestParentName] length xs @== 3 let [kps1,kps2,kps3] = xs @@ -178,7 +178,7 @@ specsWith runDb = describe "composite" $ it "Replace Child" $ runDb $ do -- c1 FKs p1 - _ <- insert p1 + insert_ p1 kc1 <- insert c1 _ <- replace kc1 c1' newc1 <- get kc1 diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 7df47ef62..f798ec50c 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -98,27 +98,27 @@ specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "foreign keys options" $ do it "delete cascades" $ runDb $ do kf <- insert $ Parent 1 - kc <- insert $ Child 1 + insert_ $ Child 1 delete kf cs <- selectList [] [] let expected = [] :: [Entity Child] cs @== expected it "update cascades" $ runDb $ do kf <- insert $ Parent 1 - kc <- insert $ Child 1 + insert_ $ Child 1 update kf [ParentName =. 2] cs <- selectList [] [] fmap (childPname . entityVal) cs @== [2] it "delete Composite cascades" $ runDb $ do kf <- insert $ ParentComposite 1 2 - kc <- insert $ ChildComposite 1 2 + insert_ $ ChildComposite 1 2 delete kf cs <- selectList [] [] let expected = [] :: [Entity ChildComposite] cs @== expected it "delete self referenced cascades" $ runDb $ do kf <- insert $ SelfReferenced 1 1 - kc <- insert $ SelfReferenced 2 1 + insert_ $ SelfReferenced 2 1 delete kf srs <- selectList [] [] let expected = [] :: [Entity SelfReferenced] @@ -135,7 +135,7 @@ specsWith runDb = describe "foreign keys options" $ do mxs `shouldBe` [] it "delete cascades with explicit Reference" $ runDb $ do kf <- insert $ A 1 40 - kc <- insert $ B 1 15 + insert_ $ B 1 15 delete kf return () cs <- selectList [] [] @@ -143,7 +143,7 @@ specsWith runDb = describe "foreign keys options" $ do cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20 - kc <- insert $ BComposite 1 20 + insert_ $ BComposite 1 20 delete kf return () cs <- selectList [] [] @@ -151,7 +151,7 @@ specsWith runDb = describe "foreign keys options" $ do cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20 - kc <- insert $ BComposite 1 20 + insert_ $ BComposite 1 20 delete kf return () cs <- selectList [] [] @@ -159,7 +159,7 @@ specsWith runDb = describe "foreign keys options" $ do cs @== expected it "delete cascades with explicit Id field" $ runDb $ do kf <- insert $ A 1 20 - kc <- insert $ BExplicit kf + insert_ $ BExplicit kf delete kf return () cs <- selectList [] [] @@ -175,7 +175,7 @@ specsWith runDb = describe "foreign keys options" $ do it "deletes cascades with self reference to the whole chain" $ runDb $ do k1 <- insert $ Chain2 1 Nothing k2 <- insert $ Chain2 2 (Just k1) - k3 <- insert $ Chain2 3 (Just k2) + insert_ $ Chain2 3 (Just k2) delete k1 cs <- selectList [] [] let expected = [] :: [Entity Chain2] diff --git a/persistent-test/src/GeneratedColumnTestSQL.hs b/persistent-test/src/GeneratedColumnTestSQL.hs new file mode 100644 index 000000000..c8753f8a8 --- /dev/null +++ b/persistent-test/src/GeneratedColumnTestSQL.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module GeneratedColumnTestSQL (specsWith) where + +import Database.Persist.TH +import Init + +share [mkPersist sqlSettings, mkMigrate "migrate1", mkDeleteCascade sqlSettings] [persistLowerCase| +GenTest sql=gen_test + fieldOne Text Maybe + fieldTwo Text Maybe + fieldThree Text Maybe generated=COALESCE(field_one,field_two) + deriving Show Eq + +MigrateTestV1 sql=gen_migrate_test + sickness Int + cromulence Int generated=5 +|] + +share [mkPersist sqlSettings, mkMigrate "migrate2", mkDeleteCascade sqlSettings] [persistLowerCase| +MigrateTestV2 sql=gen_migrate_test + sickness Int generated=3 + cromulence Int +|] + +specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith runDB = describe "PersistLiteral field" $ do + it "should read a generated column" $ runDB $ do + rawExecute "DROP TABLE IF EXISTS gen_test, gen_migrate_test;" [] + runMigration migrate1 + + insert_ $ GenTest + { genTestFieldOne = Just "like, literally this exact string" + , genTestFieldTwo = Just "like, totally some other string" + , genTestFieldThree = Nothing + } + Just (Entity _ GenTest{..}) <- selectFirst [] [] + liftIO $ genTestFieldThree @?= Just "like, literally this exact string" + + k1 <- insert $ MigrateTestV1 0 0 + Just (MigrateTestV1 sickness1 cromulence1) <- get k1 + liftIO $ sickness1 @?= 0 + liftIO $ cromulence1 @?= 5 + + it "should support adding or removing generation expressions from columns" $ runDB $ do + runMigration migrate2 + + k2 <- insert $ MigrateTestV2 0 0 + Just (MigrateTestV2 sickness2 cromulence2) <- get k2 + liftIO $ sickness2 @?= 3 + liftIO $ cromulence2 @?= 0 diff --git a/persistent-test/src/Init.hs b/persistent-test/src/Init.hs index 274d3480b..471be0a49 100644 --- a/persistent-test/src/Init.hs +++ b/persistent-test/src/Init.hs @@ -44,12 +44,18 @@ module Init ( , Proxy(..) ) where +#if !MIN_VERSION_monad_logger(0,3,30) +-- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC +-- 7.10.3 +import Control.Monad.IO.Class +import Control.Monad.Logger +import qualified Control.Monad.Fail as MonadFail +#endif + -- needed for backwards compatibility import Control.Monad.Base import Control.Monad.Catch import Control.Monad.IO.Unlift -import qualified Control.Monad.Fail as MonadFail -import Control.Monad.Logger import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Resource @@ -76,7 +82,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 qualified Data.ByteString as BS import Data.IORef diff --git a/persistent-test/src/MigrationTest.hs b/persistent-test/src/MigrationTest.hs index b032a02b9..40ec86001 100644 --- a/persistent-test/src/MigrationTest.hs +++ b/persistent-test/src/MigrationTest.hs @@ -42,14 +42,14 @@ specsWith runDb = describe "Migration" $ do again <- getMigration migrationMigrate liftIO $ again @?= [] it "really is idempotent" $ runDb $ do - runMigrationSilent migrationMigrate - runMigrationSilent migrationMigrate + void $ runMigrationSilent migrationMigrate + void $ runMigrationSilent migrationMigrate again <- getMigration migrationMigrate liftIO $ again @?= [] it "can add an extra column" $ runDb $ do -- Failing test case for #735. Foreign-key checking, switched on in -- version 2.6.1, caused persistent-sqlite to generate a `references` -- constraint in a *temporary* table during migration, which fails. - _ <- runMigrationSilent migrationAddCol + void $ runMigrationSilent migrationAddCol again <- getMigration migrationAddCol liftIO $ again @?= [] diff --git a/persistent-test/src/PersistUniqueTest.hs b/persistent-test/src/PersistUniqueTest.hs index 1f5ae8896..848b40a76 100644 --- a/persistent-test/src/PersistUniqueTest.hs +++ b/persistent-test/src/PersistUniqueTest.hs @@ -43,6 +43,6 @@ specsWith runDb = describe "custom primary key" $ do Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo' let fo'' = Fo (f + 1) (b + 1) - _ <- insert fo'' + insert_ fo'' Just (UniqueBar conflict) <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo'' conflict @== b + 1 diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index ab7ddad22..09833ea8c 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -14,7 +14,6 @@ import Control.Monad.Fail import Control.Monad.IO.Class import Data.Aeson import Data.Conduit -import qualified Data.Text as T import qualified Data.Conduit.List as CL import Data.Functor.Constant import Data.Functor.Identity @@ -28,7 +27,6 @@ import Web.PathPieces (PathPiece (..)) import Data.Proxy (Proxy(..)) import Database.Persist -import Database.Persist.Quasi import Init import PersistentTestModels import PersistTestPetType @@ -48,12 +46,12 @@ filterOrSpecs filterOrSpecs runDb = describe "FilterOr" $ do it "FilterOr []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p ps <- selectList [FilterOr []] [Desc PersonAge] assertEmpty ps it "||. []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p c <- count $ [PersonName ==. "a"] ||. [] c @== (1::Int) @@ -62,7 +60,7 @@ _polymorphic :: (MonadFail m, MonadIO m, PersistQuery backend, BaseBackend backe _polymorphic = do ((Entity id' _):_) <- selectList [] [LimitTo 1] _ <- selectList [PetOwnerId ==. id'] [] - _ <- insert $ Pet id' "foo" Cat + insert_ $ Pet id' "foo" Cat return () -- Some lens stuff @@ -86,7 +84,7 @@ specsWith runDb = describe "persistent" $ do it "FilterAnd []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p ps <- selectList [FilterAnd []] [Desc PersonAge] assertNotEmpty ps @@ -148,12 +146,12 @@ specsWith runDb = describe "persistent" $ do delete louisK let eli = Person "Eliezer" 2 $ Just "blue" - _ <- insert eli + insert_ eli pasc <- selectList [] [Asc PersonAge] map entityVal pasc @== [eli, mic29] let abe30 = Person "Abe" 30 $ Just "black" - _ <- insert abe30 + insert_ abe30 -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] map entityVal pasc @== [eli, mic29] @@ -187,9 +185,9 @@ specsWith runDb = describe "persistent" $ do it "!=." $ runDb $ do deleteWhere ([] :: [Filter (PersonGeneric backend)]) let mic = Person "Michael" 25 Nothing - _ <- insert mic + insert_ mic let eli = Person "Eliezer" 25 (Just "Red") - _ <- insert eli + insert_ eli pne <- selectList [PersonName !=. "Michael"] [] map entityVal pne @== [eli] @@ -204,9 +202,9 @@ specsWith runDb = describe "persistent" $ do it "Double Maybe" $ runDb $ do deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) let mic = PersonMay (Just "Michael") Nothing - _ <- insert mic + insert_ mic let eli = PersonMay (Just "Eliezer") (Just "Red") - _ <- insert eli + insert_ eli pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] map entityVal pe @== [] pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] @@ -266,7 +264,7 @@ specsWith runDb = describe "persistent" $ do it "deleteBy" $ runDb $ do - _ <- insert $ Person "Michael2" 27 Nothing + insert_ $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing key3 <- insert p3 @@ -445,7 +443,7 @@ specsWith runDb = describe "persistent" $ do e4 @== Nothing it "selectFirst" $ runDb $ do - _ <- insert $ Person "Michael" 26 Nothing + insert_ $ Person "Michael" 26 Nothing let pOld = Person "Oldie" 75 Nothing kOld <- insert pOld @@ -585,7 +583,7 @@ specsWith runDb = describe "persistent" $ do p2 = Person "E" 1 Nothing p3 = Person "F" 2 Nothing pid1 <- insert p1 - _ <- insert p2 + insert_ p2 pid3 <- insert p3 x <- selectList [PersonId <-. [pid1, pid3]] [] liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] @@ -638,7 +636,7 @@ specsWith runDb = describe "persistent" $ do `shouldBe` Just "This is a doc comment for a relationship.\nYou need to put the pipe character for each line of documentation.\nBut you can resume the doc comments afterwards.\n" it "provides comments on the field" $ do - let [nameField, parentField] = entityFields edef + let [nameField, _] = entityFields edef fieldComments nameField `shouldBe` Just "Fields should be documentable.\n" @@ -661,11 +659,11 @@ specsWith runDb = describe "persistent" $ do it "decodes without an ID field" $ do let - json = encode . Object . M.fromList $ + json_ = encode . Object . M.fromList $ [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) ] - decode json + decode json_ `shouldBe` Just subjectEntity diff --git a/persistent-test/src/RawSqlTest.hs b/persistent-test/src/RawSqlTest.hs index f5357a6a7..8b7cf98e9 100644 --- a/persistent-test/src/RawSqlTest.hs +++ b/persistent-test/src/RawSqlTest.hs @@ -36,16 +36,16 @@ specsWith runDb = describe "rawSql" $ do Entity _ _ <- insertEntity $ Pet p3k "Abacate" Cat escape <- getEscape person <- getTableName (error "rawSql Person" :: Person) - name <- getFieldName PersonName + name_ <- getFieldName PersonName pet <- getTableName (error "rawSql Pet" :: Pet) - petName <- getFieldName PetName + petName_ <- getFieldName PetName let query = T.concat [ "SELECT ??, ?? " , "FROM ", person , ", ", escape "Pet" , " WHERE ", person, ".", escape "age", " >= ? " , "AND ", escape "Pet", ".", escape "ownerId", " = " , person, ".", escape "id" - , " ORDER BY ", person, ".", name, ", ", pet, ".", petName + , " ORDER BY ", person, ".", name_, ", ", pet, ".", petName_ ] ret <- rawSql query [PersistInt64 20] liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1) @@ -150,9 +150,9 @@ caseCommitRollback runDb = runDb $ do let p = Person1 "foo" 0 - _ <- insert p - _ <- insert p - _ <- insert p + insert_ p + insert_ p + insert_ p c1 <- count filt c1 @== 3 @@ -161,15 +161,15 @@ caseCommitRollback runDb = runDb $ do c2 <- count filt c2 @== 3 - _ <- insert p + insert_ p transactionUndo c3 <- count filt c3 @== 3 - _ <- insert p + insert_ p transactionSave - _ <- insert p - _ <- insert p + insert_ p + insert_ p transactionUndo c4 <- count filt c4 @== 4 diff --git a/persistent-test/src/ReadWriteTest.hs b/persistent-test/src/ReadWriteTest.hs index 90aabc88b..d87a1ebf6 100644 --- a/persistent-test/src/ReadWriteTest.hs +++ b/persistent-test/src/ReadWriteTest.hs @@ -46,10 +46,10 @@ specsWith originalRunDb = describe "ReadWriteTest" $ do it "type checks on PersistUniqueWrite/Read functions" $ do runDb $ do - let name = "Matt Parsons New" - person = Person name 30 Nothing + let name_ = "Matt Parsons New" + person = Person name_ 30 Nothing _mkey0 <- insertUnique person mkey1 <- insertUnique person mkey1 @== Nothing - mperson <- selectFirst [PersonName ==. name] [] + mperson <- selectFirst [PersonName ==. name_] [] fmap entityVal mperson @== Just person diff --git a/persistent-test/src/TransactionLevelTest.hs b/persistent-test/src/TransactionLevelTest.hs index 87a06ba0b..32ee36d9b 100644 --- a/persistent-test/src/TransactionLevelTest.hs +++ b/persistent-test/src/TransactionLevelTest.hs @@ -22,6 +22,6 @@ specsWith runDb = describe "IsolationLevel" $ do it (show il ++ " works") $ runDb $ do transactionUndoWithIsolation il deleteWhere ([] :: [Filter Wombat]) - _ <- insert item + insert_ item Just item' <- get (WombatKey "uno") item' @== item diff --git a/persistent-test/src/TreeTest.hs b/persistent-test/src/TreeTest.hs index 761a9d481..46f3a748d 100644 --- a/persistent-test/src/TreeTest.hs +++ b/persistent-test/src/TreeTest.hs @@ -6,7 +6,6 @@ module TreeTest where import Init import Database.Persist.TH (mkDeleteCascade) -import Data.Proxy -- mpsGeneric = False is due to a bug or at least lack of a feature in diff --git a/persistent-test/src/UpsertTest.hs b/persistent-test/src/UpsertTest.hs index b223455f6..09ec8863a 100644 --- a/persistent-test/src/UpsertTest.hs +++ b/persistent-test/src/UpsertTest.hs @@ -148,7 +148,7 @@ specsWith runDb handleNull handleKey = describe "UpsertTests" $ do describe "putMany" $ do it "adds new rows when entity has no unique constraints" $ runDb $ do - let mkPerson name = Person1 name 25 + let mkPerson name_ = Person1 name_ 25 let names = ["putMany bob", "putMany bob", "putMany smith"] let records = map mkPerson names _ <- putMany records diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs index 41e501e48..62cdae949 100644 --- a/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs @@ -129,7 +129,9 @@ instance Binary BinPersistValue where -- put (13 :: Word8) -- put (BinZT x) - put (BinPersistValue (PersistDbSpecific _)) = undefined + put (BinPersistValue (PersistDbSpecific _)) = _ + put (BinPersistValue (PersistLiteral _)) = _ + put (BinPersistValue (PersistLiteralEscaped _)) = _ put (BinPersistValue (PersistObjectId x)) = do put (14 :: Word8) put x diff --git a/persistent-zookeeper/tests/basic-test.hs b/persistent-zookeeper/tests/basic-test.hs index 5ce81e8fb..4508e0857 100644 --- a/persistent-zookeeper/tests/basic-test.hs +++ b/persistent-zookeeper/tests/basic-test.hs @@ -91,10 +91,10 @@ main = it "StoreTest" $ do va <- flip runZookeeperPool conn $ do deleteWhere [PersonName !=. ""] - _ <- insert (Person "hoge0" 1 Nothing) - _ <- insert (Person "hoge1" 2 Nothing) - _ <- insert (Person "hoge2" 3 Nothing) - _ <- insert (Person "hoge3" 4 Nothing) + insert_ (Person "hoge0" 1 Nothing) + insert_ (Person "hoge1" 2 Nothing) + insert_ (Person "hoge2" 3 Nothing) + insert_ (Person "hoge3" 4 Nothing) selectList [PersonAge ==. 2] [] (entityVal (head va)) `shouldBe` (Person "hoge1" 2 Nothing) [Entity _k v] <- flip runZookeeperPool conn $ do diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 8f9671a8e..387c7178c 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -57,6 +57,22 @@ * Add a new type `ConnectionPoolConfig` to configure the number of connections in a pool, their idle timeout, and stripe size. * Add `defaultConnectionPoolConfig` to create a `ConnectionPoolConfig` * Add `createSqlPoolWithConfig` and `withSqlPoolWithConfig`, which take this new data type +* [#1122](https://github.com/yesodweb/persistent/pull/1122) + * Adds a new constructor, `PersistLiteral ByteString` to `PersistValue` to support unescaped SQL literals. + * Obviously, this is highly unsafe, and you should never use it with user input. + * Adds a new field, `cGenerated :: Maybe Text` to `Column` for backend-specific support of generated columns. + * Express generated fields in the Persistent DSL + + ```haskell + GeneratedColumnExample + fieldOne Text Maybe + fieldTwo Text Maybe + fieldThree Text Maybe generated=COALESCE(field_one,field_two) + ``` + + * Support for MySQL >= 5.7. (No version checking is performed! Using this feature with older versions of MySQL will cause runtime SQL exceptions!) + * Support for Postgresql >= 12. (No version checking is performed! Using this feature with older versions of Postgresql will cause runtime SQL exceptions!) + * No support for Sqlite at this time. (`generated=` will be safely ignored.) * [#1151](https://github.com/yesodweb/persistent/pull/1151) * Allow `OverloadedLabels` to be used with the `EntityField` type. diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index c94ea4d51..4aa8cd830 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' module Database.Persist.Class.PersistField ( PersistField (..) , SomePersistField (..) @@ -111,7 +112,9 @@ instance {-# OVERLAPPING #-} PersistField [Char] where fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" - fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent." + fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String" + fromPersistValue (PersistLiteralEscaped _) = Left $ T.pack "Cannot convert PersistLiteralEscaped to String" + fromPersistValue (PersistLiteral _) = Left $ T.pack "Cannot convert PersistLiteral to String" fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index 556151a8e..f8f8f87b4 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -34,7 +34,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes) -import Data.Text (Text) import GHC.TypeLits (ErrorMessage(..)) import Database.Persist.Types diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 33f95e498..80d49e0aa 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -435,12 +435,12 @@ module Database.Persist.Quasi import Prelude hiding (lines) -import qualified Data.List.NonEmpty as NEL -import Data.List.NonEmpty (NonEmpty(..)) import Control.Arrow ((&&&)) import Control.Monad (msum, mplus) import Data.Char 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) @@ -840,7 +840,7 @@ mkEntityDef :: PersistSettings mkEntityDef ps name entattribs lines = UnboundEntityDef foreigns $ EntityDef - { entityHaskell = entName + { entityHaskell = HaskellName name' , entityDB = DBName $ getDbName ps name' entattribs -- idField is the user-specified Id -- otherwise useAutoIdField @@ -850,13 +850,12 @@ mkEntityDef ps name entattribs lines = , entityFields = cols , entityUniques = uniqs , entityForeigns = [] - , entityDerives = derives + , entityDerives = concat $ mapMaybe takeDerives attribs , entityExtra = extras , entitySum = isSum - , entityComments = comments + , entityComments = Nothing } where - comments = Nothing entName = HaskellName name' (isSum, name') = case T.uncons name of @@ -873,8 +872,6 @@ mkEntityDef ps name entattribs lines = squish xs m = xs `mappend` maybeToList m in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs - derives = concat $ mapMaybe takeDerives attribs - cols :: [FieldDef] cols = reverse . fst . foldr k ([], []) $ reverse attribs k x (!acc, !comments) = @@ -962,7 +959,7 @@ takeCols onErr ps (n':typ:rest') , fieldDB = DBName $ getDbName ps n attrs_ , fieldType = ft , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = attrs_ + , fieldAttrs = parseFieldAttrs attrs_ , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference , fieldComments = Nothing @@ -1018,7 +1015,7 @@ takeId ps tableName (n:rest) = 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] + -- setIdName = ["sql=" `mappend` psIdName ps] takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName @@ -1166,8 +1163,8 @@ parseCascade :: [Text] -> (FieldCascade, [Text]) parseCascade allTokens = go [] Nothing Nothing allTokens where - go acc mupd mdel tokens = - case tokens of + go acc mupd mdel tokens_ = + case tokens_ of [] -> ( FieldCascade { fcOnDelete = mdel @@ -1217,8 +1214,8 @@ takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing -nullable :: [Text] -> IsNullable +nullable :: [FieldAttr] -> IsNullable nullable s - | "Maybe" `elem` s = Nullable ByMaybeAttr - | "nullable" `elem` s = Nullable ByNullableAttr + | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr + | FieldAttrNullable `elem` s = Nullable ByNullableAttr | otherwise = NotNullable diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 22ed8b983..09210449f 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -30,9 +30,7 @@ import qualified Data.Text.Lazy as TL import Data.Time (UTCTime, TimeOfDay, Day) import qualified Data.Vector as V import Data.Word -import Numeric.Natural (Natural) import Text.Blaze.Html (Html) -import GHC.TypeLits import Database.Persist import Database.Persist.Sql.Types diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index ece17e119..e01685130 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -6,12 +7,12 @@ module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute + , generatedAttribute , BackendSpecificOverrides(..) , emptyBackendSpecificOverrides ) where import Control.Applicative ((<|>)) -import Data.Char (isSpace) import Data.Monoid (mappend, mconcat) import Data.Text (Text) import qualified Data.Text as T @@ -30,14 +31,24 @@ data BackendSpecificOverrides = BackendSpecificOverrides { backendSpecificForeignKeyName :: Maybe (DBName -> DBName -> DBName) } +findMaybe :: (a -> Maybe b) -> [a] -> Maybe b +findMaybe p = listToMaybe . mapMaybe p + -- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides) -- -- @since 2.11 emptyBackendSpecificOverrides :: BackendSpecificOverrides emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing -defaultAttribute :: [Attr] -> Maybe Text -defaultAttribute = listToMaybe . mapMaybe (T.stripPrefix "default=") +defaultAttribute :: [FieldAttr] -> Maybe Text +defaultAttribute = findMaybe $ \case + FieldAttrDefault x -> Just x + _ -> Nothing + +generatedAttribute :: [FieldAttr] -> Maybe Text +generatedAttribute = findMaybe $ \case + FieldAttrGenerated x -> Just x + _ -> Nothing -- | Create the list of columns for the given entity. mkColumns @@ -56,6 +67,7 @@ mkColumns allDefs t overrides = Just _ -> [] Nothing -> [entityId t] + goId :: FieldDef -> Column goId fd = Column { cName = fieldDB fd @@ -87,6 +99,7 @@ mkColumns allDefs t overrides = Just def -> Just def + , cGenerated = generatedAttribute $ fieldAttrs fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd @@ -103,20 +116,16 @@ mkColumns allDefs t overrides = , cNull = nullable (fieldAttrs fd) /= NotNullable || entitySum t , cSqlType = fieldSqlType fd , cDefault = defaultAttribute $ fieldAttrs fd + , cGenerated = generatedAttribute $ fieldAttrs fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd } - maxLen :: [Attr] -> Maybe Integer - maxLen [] = Nothing - maxLen (a:as) - | Just d <- T.stripPrefix "maxlen=" a = - case reads (T.unpack d) of - [(i, s)] | all isSpace s -> Just i - _ -> error $ "Could not parse maxlen field with value " ++ - show d ++ " on " ++ show tableName - | otherwise = maxLen as + maxLen :: [FieldAttr] -> Maybe Integer + maxLen = findMaybe $ \case + FieldAttrMaxlen n -> Just n + _ -> Nothing refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides) @@ -139,21 +148,21 @@ mkColumns allDefs t overrides = ref :: DBName -> ReferenceDef - -> [Attr] + -> [FieldAttr] -> Maybe (DBName, DBName) -- table name, constraint name ref c fe [] | ForeignRef f _ <- fe = Just (resolveTableName allDefs f, refNameFn tableName c) | otherwise = Nothing - ref _ _ ("noreference":_) = Nothing - ref c fe (a:as) - | Just x <- T.stripPrefix "reference=" a = do - (_, constraintName) <- ref c fe as + ref _ _ (FieldAttrNoreference:_) = Nothing + ref c fe (a:as) = case a of + FieldAttrReference x -> do + (_, constraintName) <- ref c fe as pure (DBName x, constraintName) - | Just x <- T.stripPrefix "constraint=" a = do - (tableName, _) <- ref c fe as - pure (tableName, DBName x) - ref c x (_:as) = ref c x as + FieldAttrConstraint x -> do + (tableName_, _) <- ref c fe as + pure (tableName_, DBName x) + _ -> ref c fe as refName :: DBName -> DBName -> DBName refName (DBName table) (DBName column) = diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index 8d43a2c37..edcd9a840 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -41,12 +41,28 @@ import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Database.Persist import Database.Persist.Class () import Database.Persist.Sql.Class (PersistFieldSql) +import Database.Persist.Sql.Internal (generatedAttribute) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types import Database.Persist.Sql.Util ( dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames , updatePersistValue, mkUpdateText, commaSeparated) +-- Contributor note: any time you execute a prepared statement to +-- insert one or more rows, you need to use 'valuesToInsert entity' to +-- generate the list of values that you feed into your prepared +-- statement so that generated columns are properly scrubbed. +valuesToInsert :: PersistEntity entity => entity -> [PersistValue] +valuesToInsert entity = + zipWith redactGeneratedCol (entityFields . entityDef $ Just entity) + . map toPersistValue + $ toPersistFields entity + where + redactGeneratedCol fd pv = case generatedAttribute (fieldAttrs fd) of + Nothing -> pv + -- TODO: this redaction works fine in MySQL and Postgresql, but not Sqlite. + Just _ -> PersistLiteral "DEFAULT" + withRawQuery :: MonadIO m => Text -> [PersistValue] @@ -208,7 +224,7 @@ instance PersistStoreWrite SqlBackend where tshow = T.pack . show throw = liftIO . throwIO . userError . T.unpack t = entityDef $ Just val - vals = map toPersistValue $ toPersistFields val + vals = valuesToInsert val insertMany [] = return [] insertMany vals = do @@ -222,14 +238,14 @@ instance PersistStoreWrite SqlBackend where _ -> error "ISRSingle is expected from the connInsertManySql function" where ent = entityDef vals - valss = map (map toPersistValue . toPersistFields) vals + valss = map valuesToInsert vals insertMany_ vals0 = runChunked (length $ entityFields t) insertMany_' vals0 where t = entityDef vals0 insertMany_' vals = do conn <- ask - let valss = map (map toPersistValue . toPersistFields) vals + let valss = map valuesToInsert vals let sql = T.concat [ "INSERT INTO " , connEscapeName conn (entityDB t) @@ -253,7 +269,7 @@ instance PersistStoreWrite SqlBackend where , " WHERE " , wher ] - vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k + vals = valuesToInsert val `mappend` keyToValues k rawExecute sql vals where go conn x = connEscapeName conn x `T.append` "=?" @@ -283,8 +299,8 @@ instance PersistStoreWrite SqlBackend where let nr = length krs let toVals (k,r) = case entityPrimary ent of - Nothing -> keyToValues k <> (toPersistValue <$> toPersistFields r) - Just _ -> toPersistValue <$> toPersistFields r + Nothing -> keyToValues k <> (valuesToInsert r) + Just _ -> valuesToInsert r case connRepsertManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals krs) Nothing -> mapM_ (uncurry repsert) krs diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs index deac0c158..b2a96f91a 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -5,8 +5,8 @@ module Database.Persist.Sql.Orphan.PersistUnique where import Control.Exception (throwIO) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Trans.Reader (ask, withReaderT, ReaderT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ask, withReaderT) import qualified Data.Conduit.List as CL import Data.Function (on) import Data.List (nubBy) @@ -15,8 +15,7 @@ import Data.Monoid (mappend) import qualified Data.Text as T import Database.Persist -import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues - , onlyOneUniqueDef, atLeastOneUniqueDef) +import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index cc1171e7d..33c104963 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -6,7 +6,6 @@ module Database.Persist.Sql.Types , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend , OverflowNatural(..) , ConnectionPoolConfig(..) - , defaultConnectionPoolConfig ) where import Database.Persist.Types.Base (FieldCascade) @@ -28,6 +27,7 @@ data Column = Column , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text) + , cGenerated :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe ColumnReference) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 8ef4bd075..0b19e93fe 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass module Database.Persist.Types.Base where @@ -10,6 +11,7 @@ import Data.ByteString (ByteString, foldl') import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isSpace) import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Map (Map) @@ -173,6 +175,51 @@ newtype DBName = DBName { unDBName :: Text } type Attr = Text +-- | Attributes that may be attached to fields that can affect migrations +-- and serialization in backend-specific ways. +-- +-- While we endeavor to, we can't forsee all use cases for all backends, +-- and so 'FieldAttr' is extensible through its constructor 'FieldAttrOther'. +-- +-- @since 2.11.0.0 +data FieldAttr + = FieldAttrMaybe + | FieldAttrNullable + | FieldAttrMigrationOnly + | FieldAttrSafeToRemove + | FieldAttrNoreference + | FieldAttrReference Text + | FieldAttrConstraint Text + | FieldAttrDefault Text + | FieldAttrGenerated Text + | FieldAttrSqltype Text + | FieldAttrMaxlen Integer + | FieldAttrOther Text + deriving (Show, Eq, Read, Ord) + +-- | Parse raw field attributes into structured form. Any unrecognized +-- attributes will be preserved, identically as they are encountered, +-- as 'FieldAttrOther' values. +-- +-- @since 2.11.0.0 +parseFieldAttrs :: [Text] -> [FieldAttr] +parseFieldAttrs = fmap $ \case + "Maybe" -> FieldAttrMaybe + "nullable" -> FieldAttrNullable + "MigrationOnly" -> FieldAttrMigrationOnly + "SafeToRemove" -> FieldAttrSafeToRemove + "noreference" -> FieldAttrNoreference + raw + | Just x <- T.stripPrefix "reference=" raw -> FieldAttrReference x + | Just x <- T.stripPrefix "constraint=" raw -> FieldAttrConstraint x + | Just x <- T.stripPrefix "default=" raw -> FieldAttrDefault x + | Just x <- T.stripPrefix "generated=" raw -> FieldAttrGenerated x + | Just x <- T.stripPrefix "sqltype=" raw -> FieldAttrSqltype x + | Just x <- T.stripPrefix "maxlen=" raw -> case reads (T.unpack x) of + [(n, s)] | all isSpace s -> FieldAttrMaxlen n + _ -> error $ "Could not parse maxlen field with value " <> show raw + | otherwise -> FieldAttrOther raw + -- | A 'FieldType' describes a field parsed from the QuasiQuoter and is -- used to determine the Haskell type in the generated code. -- @@ -192,7 +239,7 @@ data FieldType | FTList FieldType deriving (Show, Eq, Read, Ord) --- | A 'FieldDef' represents the inormation that @persistent@ knows about +-- | A 'FieldDef' represents the information that @persistent@ knows about -- a field of a datatype. This includes information used to parse the field -- out of the database and what the field corresponds to. data FieldDef = FieldDef @@ -209,7 +256,8 @@ data FieldDef = FieldDef -- ^ The type of the field in Haskell. , fieldSqlType :: !SqlType -- ^ The type of the field in a SQL database. - , fieldAttrs :: ![Attr] + , fieldAttrs :: ![FieldAttr] + -- ^ Whether or not the field is gnerated and how. Backend-dependent. -- ^ User annotations for a field. These are provided with the @!@ -- operator. , fieldStrict :: !Bool @@ -399,21 +447,24 @@ instance Error PersistException where -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. -data PersistValue = PersistText Text - | PersistByteString ByteString - | PersistInt64 Int64 - | PersistDouble Double - | PersistRational Rational - | PersistBool Bool - | PersistDay Day - | PersistTimeOfDay TimeOfDay - | PersistUTCTime UTCTime - | PersistNull - | PersistList [PersistValue] - | PersistMap [(Text, PersistValue)] - | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend - | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays - | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend +data PersistValue + = PersistText Text + | PersistByteString ByteString + | PersistInt64 Int64 + | PersistDouble Double + | PersistRational Rational + | PersistBool Bool + | PersistDay Day + | PersistTimeOfDay TimeOfDay + | PersistUTCTime UTCTime + | PersistNull + | PersistList [PersistValue] + | PersistMap [(Text, PersistValue)] + | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend + | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays + | PersistLiteral ByteString -- ^ Using 'PersistLiteral' allows you to use types or keywords specific to a particular backend. + | PersistLiteralEscaped ByteString -- ^ Similar to 'PersistLiteral', but escapes the @ByteString@. + | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend. -- For example, below is a simple example of the PostGIS geography type: -- -- @ @@ -441,6 +492,7 @@ data PersistValue = PersistText Text -- deriving (Show, Read, Eq, Ord) +{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. Use one of 'PersistLiteral' or 'PersistLiteralEscaped' instead." #-} instance ToHttpApiData PersistValue where toUrlPiece val = @@ -478,7 +530,9 @@ fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" -fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent." +fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text" +fromPersistValueText (PersistLiteral _) = Left "Cannot convert PersistLiteral to Text" +fromPersistValueText (PersistLiteralEscaped _) = Left "Cannot convert PersistLiteralEscaped to Text" instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t @@ -494,6 +548,8 @@ instance A.ToJSON PersistValue where toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map (second A.toJSON) m toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b + toJSON (PersistLiteral b) = A.String $ T.cons 'l' $ TE.decodeUtf8 $ B64.encode b + toJSON (PersistLiteralEscaped b) = A.String $ T.cons 'e' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a toJSON (PersistObjectId o) = A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" @@ -518,6 +574,10 @@ instance A.FromJSON PersistValue where Nothing -> fail "Null string" Just ('p', t) -> either (\_ -> fail "Invalid base64") (return . PersistDbSpecific) $ B64.decode $ TE.encodeUtf8 t + Just ('l', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteral) + $ B64.decode $ TE.encodeUtf8 t + Just ('e', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped) + $ B64.decode $ TE.encodeUtf8 t Just ('s', t) -> return $ PersistText t Just ('b', t) -> either (\_ -> fail "Invalid base64") (return . PersistByteString) $ B64.decode $ TE.encodeUtf8 t