diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for persistent-postgresql +## 2.13.2.1 + +* [#1331](https://github.com/yesodweb/persistent/pull/1331) + * Fixes a bug where `upsertWhere` would fail on a database table with + `MigrationOnly` fields. + +## 2.13.2.0 +* [#1316](https://github.com/yesodweb/persistent/pull/1316) + * Expose some internals in the new `Database.Persist.Postgresql.Internal` module. + This gives access to the `P` newtype, which is used for de-serializing `PersistValue`s + from `postgresql-simple` code. + ## 2.13.1.0 * [#1305](https://github.com/yesodweb/persistent/pull/1305) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -67,9 +67,7 @@ import qualified Database.PostgreSQL.Simple.FromField as PGFF import qualified Database.PostgreSQL.Simple.Internal as PG import Database.PostgreSQL.Simple.Ok (Ok(..)) -import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.Transaction as PG -import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import qualified Database.PostgreSQL.Simple.Types as PG import Control.Arrow @@ -86,47 +84,38 @@ import qualified Data.List.NonEmpty as NEL import Data.Proxy (Proxy(..)) -import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) -import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.Attoparsec.Text as AT -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 import qualified Data.Conduit.List as CL -import Data.Data (Data, Typeable) +import Data.Data (Data) import Data.Either (partitionEithers) -import Data.Fixed (Fixed(..), Pico) import Data.Function (on) import Data.IORef import Data.Int (Int64) -import qualified Data.IntMap as I import Data.List (find, foldl', groupBy, sort) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Monoid as Monoid import Data.Pool (Pool) -import Data.String.Conversions.Monomorphic (toStrictByteString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Text.Read (rational) -import Data.Time (NominalDiffTime, localTimeToUTC, utc) import System.Environment (getEnvironment) #if MIN_VERSION_base(4,12,0) import Database.Persist.Compatible #endif +import Database.Persist.Postgresql.Internal import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util import Database.Persist.SqlBackend @@ -524,7 +513,7 @@ rowCount <- LibPQ.ntuples ret return (ret, rowRef, rowCount, oids) let getters - = map (\(col, oid) -> getGetter conn oid $ PG.Field rt col oid) ids + = map (\(col, oid) -> getGetter oid $ PG.Field rt col oid) ids return (rt, rr, rc, getters) closeS (ret, _, _, _) = LibPQ.unsafeFreeResult ret @@ -555,240 +544,6 @@ Errors [] -> error "Got an Errors, but no exceptions" Ok v -> return v --- | Avoid orphan instances. -newtype P = P PersistValue - - -instance PGTF.ToField P where - toField (P (PersistText t)) = PGTF.toField t - toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) - toField (P (PersistInt64 i)) = PGTF.toField i - toField (P (PersistDouble d)) = PGTF.toField d - toField (P (PersistRational r)) = PGTF.Plain $ - BBB.fromString $ - show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field - toField (P (PersistBool b)) = PGTF.toField b - toField (P (PersistDay d)) = PGTF.toField d - toField (P (PersistTimeOfDay t)) = PGTF.toField t - toField (P (PersistUTCTime t)) = PGTF.toField t - toField (P PersistNull) = PGTF.toField PG.Null - toField (P (PersistList l)) = PGTF.toField $ listToJSON l - toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m - toField (P (PersistLiteral_ DbSpecific s)) = PGTF.toField (Unknown s) - toField (P (PersistLiteral_ Unescaped l)) = PGTF.toField (UnknownLiteral l) - toField (P (PersistLiteral_ Escaped 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" - --- | Represent Postgres interval using NominalDiffTime --- --- @since 2.11.0.0 -newtype PgInterval = PgInterval { getPgInterval :: NominalDiffTime } - deriving (Eq, Show) - -pgIntervalToBs :: PgInterval -> ByteString -pgIntervalToBs = toStrictByteString . show . getPgInterval - -instance PGTF.ToField PgInterval where - toField (PgInterval t) = PGTF.toField t - -instance PGFF.FromField PgInterval where - fromField f mdata = - if PGFF.typeOid f /= PS.typoid PS.interval - then PGFF.returnError PGFF.Incompatible f "" - else case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" - Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of - Left msg -> PGFF.returnError PGFF.ConversionFailed f msg - Right t -> return $ PgInterval t - - where - toPico :: Integer -> Pico - toPico = MkFixed - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - twoDigits :: P.Parser Int - twoDigits = do - a <- P.digit - b <- P.digit - let c2d c = ord c .&. 15 - return $! c2d a * 10 + c2d b - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - seconds :: P.Parser Pico - seconds = do - real <- twoDigits - mc <- P.peekChar - case mc of - Just '.' -> do - t <- P.anyChar *> P.takeWhile1 P.isDigit - return $! parsePicos (fromIntegral real) t - _ -> return $! fromIntegral real - where - parsePicos :: Int64 -> B8.ByteString -> Pico - parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) - where n = max 0 (12 - B8.length t) - t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 - (B8.take 12 t) - - parseSign :: P.Parser Bool - parseSign = P.choice [P.char '-' >> return True, return False] - - -- Db stores it in [-]HHH:MM:SS.[SSSS] - -- For example, nominalDay is stored as 24:00:00 - interval :: P.Parser (Bool, Int, Int, Pico) - interval = do - s <- parseSign - h <- P.decimal <* P.char ':' - m <- twoDigits <* P.char ':' - ss <- seconds - if m < 60 && ss <= 60 - then return (s, h, m, ss) - else fail "Invalid interval" - - nominalDiffTime :: P.Parser NominalDiffTime - nominalDiffTime = do - (s, h, m, ss) <- interval - 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" - -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". - -> PersistValue -- ^ Incorrect value - -> Text -- ^ Error message -fromPersistValueError haskellType databaseType received = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`; expected " - , databaseType - , " from database, but received: " - , T.pack (show received) - , ". Potential solution: Check that your database schema matches your Persistent model definitions." - ] - -instance PersistField PgInterval where - toPersistValue = PersistLiteralEscaped . pgIntervalToBs - fromPersistValue (PersistLiteral_ DbSpecific bs) = - fromPersistValue (PersistLiteralEscaped bs) - fromPersistValue x@(PersistLiteral_ Escaped 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 - fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x - -instance PersistFieldSql PgInterval where - sqlType _ = SqlOther "interval" - -newtype Unknown = Unknown { unUnknown :: ByteString } - deriving (Eq, Show, Read, Ord) - -instance PGFF.FromField Unknown where - fromField f mdata = - case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField Unknown" - Just dat -> return (Unknown dat) - -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 -convertPV f = (fmap f .) . PGFF.fromField - -builtinGetters :: I.IntMap (Getter PersistValue) -builtinGetters = I.fromList - [ (k PS.bool, convertPV PersistBool) - , (k PS.bytea, convertPV (PersistByteString . unBinary)) - , (k PS.char, convertPV PersistText) - , (k PS.name, convertPV PersistText) - , (k PS.int8, convertPV PersistInt64) - , (k PS.int2, convertPV PersistInt64) - , (k PS.int4, convertPV PersistInt64) - , (k PS.text, convertPV PersistText) - , (k PS.xml, convertPV (PersistByteString . unUnknown)) - , (k PS.float4, convertPV PersistDouble) - , (k PS.float8, convertPV PersistDouble) - , (k PS.money, convertPV PersistRational) - , (k PS.bpchar, convertPV PersistText) - , (k PS.varchar, convertPV PersistText) - , (k PS.date, convertPV PersistDay) - , (k PS.time, convertPV PersistTimeOfDay) - , (k PS.timestamp, convertPV (PersistUTCTime. localTimeToUTC utc)) - , (k PS.timestamptz, convertPV PersistUTCTime) - , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) - , (k PS.bit, convertPV PersistInt64) - , (k PS.varbit, convertPV PersistInt64) - , (k PS.numeric, convertPV PersistRational) - , (k PS.void, \_ _ -> return PersistNull) - , (k PS.json, convertPV (PersistByteString . unUnknown)) - , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) - , (k PS.unknown, convertPV (PersistByteString . unUnknown)) - - -- Array types: same order as above. - -- The OIDs were taken from pg_type. - , (1000, listOf PersistBool) - , (1001, listOf (PersistByteString . unBinary)) - , (1002, listOf PersistText) - , (1003, listOf PersistText) - , (1016, listOf PersistInt64) - , (1005, listOf PersistInt64) - , (1007, listOf PersistInt64) - , (1009, listOf PersistText) - , (143, listOf (PersistByteString . unUnknown)) - , (1021, listOf PersistDouble) - , (1022, listOf PersistDouble) - , (1023, listOf PersistUTCTime) - , (1024, listOf PersistUTCTime) - , (791, listOf PersistRational) - , (1014, listOf PersistText) - , (1015, listOf PersistText) - , (1182, listOf PersistDay) - , (1183, listOf PersistTimeOfDay) - , (1115, listOf PersistUTCTime) - , (1185, listOf PersistUTCTime) - , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) - , (1561, listOf PersistInt64) - , (1563, listOf PersistInt64) - , (1231, listOf PersistRational) - -- no array(void) type - , (2951, listOf (PersistLiteralEscaped . unUnknown)) - , (199, listOf (PersistByteString . unUnknown)) - , (3807, listOf (PersistByteString . unUnknown)) - -- no array(unknown) either - ] - where - k (PGFF.typoid -> i) = PG.oid2int i - -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert - -- the values to Haskell-land. The @Maybe@ is important - -- because the usual way of checking NULLs - -- (c.f. withStmt') won't check for NULL inside - -- arrays---or any other compound structure for that matter. - listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) - where nullable = maybe PersistNull - -getGetter :: PG.Connection -> PG.Oid -> Getter PersistValue -getGetter _conn oid - = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters - where defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) - -unBinary :: PG.Binary a -> a -unBinary (PG.Binary x) = x - doesTableExist :: (Text -> IO Statement) -> EntityNameDB -> IO Bool @@ -1971,7 +1726,7 @@ firstField = case entityFieldNames of [] -> error "The entity you're trying to insert does not have any fields." (field:_) -> field - entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef') + entityFieldNames = map fieldDbToText (getEntityFields entityDef') nameOfTable = escapeE . getEntityDBName $ entityDef' copyUnlessValues = map snd fieldsToMaybeCopy recordValues = concatMap (map toPersistValue . toPersistFields) records @@ -2073,13 +1828,13 @@ -- -- @since 2.13.1.0 data RawPostgresql backend = RawPostgresql - { persistentBackend :: backend + { persistentBackend :: backend -- ^ The persistent backend -- -- @since 2.13.1.0 - , rawPostgresqlConnection :: PG.Connection + , rawPostgresqlConnection :: PG.Connection -- ^ The underlying `PG.Connection` - -- + -- -- @since 2.13.1.0 } diff --git a/Database/Persist/Postgresql/Internal.hs b/Database/Persist/Postgresql/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Postgresql/Internal.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.Persist.Postgresql.Internal + ( P(..) + , PgInterval(..) + , getGetter + ) where + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import qualified Database.PostgreSQL.Simple.ToField as PGTF +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS +import qualified Database.PostgreSQL.Simple.Types as PG + +import qualified Blaze.ByteString.Builder.Char8 as BBB +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.Data (Typeable) +import Data.Fixed (Fixed(..), Pico) +import Data.Int (Int64) +import qualified Data.IntMap as I +import Data.Maybe (fromMaybe) +import Data.String.Conversions.Monomorphic (toStrictByteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time (NominalDiffTime, localTimeToUTC, utc) + +import Database.Persist.Sql + +-- | Newtype used to avoid orphan instances for @postgresql-simple@ classes. +-- +-- @since 2.13.2.0 +newtype P = P { unP :: PersistValue } + +instance PGTF.ToField P where + toField (P (PersistText t)) = PGTF.toField t + toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) + toField (P (PersistInt64 i)) = PGTF.toField i + toField (P (PersistDouble d)) = PGTF.toField d + toField (P (PersistRational r)) = PGTF.Plain $ + BBB.fromString $ + show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field + toField (P (PersistBool b)) = PGTF.toField b + toField (P (PersistDay d)) = PGTF.toField d + toField (P (PersistTimeOfDay t)) = PGTF.toField t + toField (P (PersistUTCTime t)) = PGTF.toField t + toField (P PersistNull) = PGTF.toField PG.Null + toField (P (PersistList l)) = PGTF.toField $ listToJSON l + toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m + toField (P (PersistLiteral_ DbSpecific s)) = PGTF.toField (Unknown s) + toField (P (PersistLiteral_ Unescaped l)) = PGTF.toField (UnknownLiteral l) + toField (P (PersistLiteral_ Escaped 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" + +instance PGFF.FromField P where + fromField field mdata = fmap P $ case mdata of + -- If we try to simply decode based on oid, we will hit unexpected null + -- errors. + Nothing -> pure PersistNull + data' -> getGetter (PGFF.typeOid field) field data' + +newtype Unknown = Unknown { unUnknown :: ByteString } + deriving (Eq, Show, Read, Ord) + +instance PGFF.FromField Unknown where + fromField f mdata = + case mdata of + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField Unknown" + Just dat -> return (Unknown dat) + +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 +convertPV f = (fmap f .) . PGFF.fromField + +builtinGetters :: I.IntMap (Getter PersistValue) +builtinGetters = I.fromList + [ (k PS.bool, convertPV PersistBool) + , (k PS.bytea, convertPV (PersistByteString . unBinary)) + , (k PS.char, convertPV PersistText) + , (k PS.name, convertPV PersistText) + , (k PS.int8, convertPV PersistInt64) + , (k PS.int2, convertPV PersistInt64) + , (k PS.int4, convertPV PersistInt64) + , (k PS.text, convertPV PersistText) + , (k PS.xml, convertPV (PersistByteString . unUnknown)) + , (k PS.float4, convertPV PersistDouble) + , (k PS.float8, convertPV PersistDouble) + , (k PS.money, convertPV PersistRational) + , (k PS.bpchar, convertPV PersistText) + , (k PS.varchar, convertPV PersistText) + , (k PS.date, convertPV PersistDay) + , (k PS.time, convertPV PersistTimeOfDay) + , (k PS.timestamp, convertPV (PersistUTCTime. localTimeToUTC utc)) + , (k PS.timestamptz, convertPV PersistUTCTime) + , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) + , (k PS.bit, convertPV PersistInt64) + , (k PS.varbit, convertPV PersistInt64) + , (k PS.numeric, convertPV PersistRational) + , (k PS.void, \_ _ -> return PersistNull) + , (k PS.json, convertPV (PersistByteString . unUnknown)) + , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) + , (k PS.unknown, convertPV (PersistByteString . unUnknown)) + + -- Array types: same order as above. + -- The OIDs were taken from pg_type. + , (1000, listOf PersistBool) + , (1001, listOf (PersistByteString . unBinary)) + , (1002, listOf PersistText) + , (1003, listOf PersistText) + , (1016, listOf PersistInt64) + , (1005, listOf PersistInt64) + , (1007, listOf PersistInt64) + , (1009, listOf PersistText) + , (143, listOf (PersistByteString . unUnknown)) + , (1021, listOf PersistDouble) + , (1022, listOf PersistDouble) + , (1023, listOf PersistUTCTime) + , (1024, listOf PersistUTCTime) + , (791, listOf PersistRational) + , (1014, listOf PersistText) + , (1015, listOf PersistText) + , (1182, listOf PersistDay) + , (1183, listOf PersistTimeOfDay) + , (1115, listOf PersistUTCTime) + , (1185, listOf PersistUTCTime) + , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) + , (1561, listOf PersistInt64) + , (1563, listOf PersistInt64) + , (1231, listOf PersistRational) + -- no array(void) type + , (2951, listOf (PersistLiteralEscaped . unUnknown)) + , (199, listOf (PersistByteString . unUnknown)) + , (3807, listOf (PersistByteString . unUnknown)) + -- no array(unknown) either + ] + where + k (PGFF.typoid -> i) = PG.oid2int i + -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert + -- the values to Haskell-land. The @Maybe@ is important + -- because the usual way of checking NULLs + -- (c.f. withStmt') won't check for NULL inside + -- arrays---or any other compound structure for that matter. + listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) + where nullable = maybe PersistNull + +-- | Get the field parser corresponding to the given 'PG.Oid'. +-- +-- For example, pass in the 'PG.Oid' of 'PS.bool', and you will get back a +-- field parser which parses boolean values in the table into 'PersistBool's. +-- +-- @since 2.13.2.0 +getGetter :: PG.Oid -> Getter PersistValue +getGetter oid + = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters + where defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) + +unBinary :: PG.Binary a -> a +unBinary (PG.Binary x) = x + +-- | Represent Postgres interval using NominalDiffTime +-- +-- @since 2.11.0.0 +newtype PgInterval = PgInterval { getPgInterval :: NominalDiffTime } + deriving (Eq, Show) + +pgIntervalToBs :: PgInterval -> ByteString +pgIntervalToBs = toStrictByteString . show . getPgInterval + +instance PGTF.ToField PgInterval where + toField (PgInterval t) = PGTF.toField t + +instance PGFF.FromField PgInterval where + fromField f mdata = + if PGFF.typeOid f /= PS.typoid PS.interval + then PGFF.returnError PGFF.Incompatible f "" + else case mdata of + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" + Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of + Left msg -> PGFF.returnError PGFF.ConversionFailed f msg + Right t -> return $ PgInterval t + + where + toPico :: Integer -> Pico + toPico = MkFixed + + -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser + twoDigits :: P.Parser Int + twoDigits = do + a <- P.digit + b <- P.digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + + -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser + seconds :: P.Parser Pico + seconds = do + real <- twoDigits + mc <- P.peekChar + case mc of + Just '.' -> do + t <- P.anyChar *> P.takeWhile1 P.isDigit + return $! parsePicos (fromIntegral real) t + _ -> return $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where n = max 0 (12 - B8.length t) + t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 + (B8.take 12 t) + + parseSign :: P.Parser Bool + parseSign = P.choice [P.char '-' >> return True, return False] + + -- Db stores it in [-]HHH:MM:SS.[SSSS] + -- For example, nominalDay is stored as 24:00:00 + interval :: P.Parser (Bool, Int, Int, Pico) + interval = do + s <- parseSign + h <- P.decimal <* P.char ':' + m <- twoDigits <* P.char ':' + ss <- seconds + if m < 60 && ss <= 60 + then return (s, h, m, ss) + else fail "Invalid interval" + + nominalDiffTime :: P.Parser NominalDiffTime + nominalDiffTime = do + (s, h, m, ss) <- interval + 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" + -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". + -> PersistValue -- ^ Incorrect value + -> Text -- ^ Error message +fromPersistValueError haskellType databaseType received = T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`; expected " + , databaseType + , " from database, but received: " + , T.pack (show received) + , ". Potential solution: Check that your database schema matches your Persistent model definitions." + ] + +instance PersistField PgInterval where + toPersistValue = PersistLiteralEscaped . pgIntervalToBs + fromPersistValue (PersistLiteral_ DbSpecific bs) = + fromPersistValue (PersistLiteralEscaped bs) + fromPersistValue x@(PersistLiteral_ Escaped 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 + fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x + +instance PersistFieldSql PgInterval where + sqlType _ = SqlOther "interval" + + diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.1.0 +version: 2.13.2.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -35,6 +35,7 @@ , transformers >= 0.5 , unliftio-core exposed-modules: Database.Persist.Postgresql + , Database.Persist.Postgresql.Internal , Database.Persist.Postgresql.JSON ghc-options: -Wall default-language: Haskell2010 diff --git a/test/UpsertWhere.hs b/test/UpsertWhere.hs --- a/test/UpsertWhere.hs +++ b/test/UpsertWhere.hs @@ -16,6 +16,7 @@ import PgInit +import Data.Time import Database.Persist.Postgresql share [mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"] [persistLowerCase| @@ -29,11 +30,21 @@ UniqueName name deriving Eq Show Ord +ItemMigOnly + name Text + price Double + quantity Int + + UniqueNameMigOnly name + + createdAt UTCTime MigrationOnly default=CURRENT_TIMESTAMP + |] wipe :: IO () wipe = runConnAssert $ do deleteWhere ([] :: [Filter Item]) + deleteWhere ([] :: [Filter ItemMigOnly]) itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) itDb msg action = it msg $ runConnAssert $ void action @@ -58,6 +69,12 @@ [] Just item <- fmap entityVal <$> getBy (UniqueName "item1") item `shouldBe` item1 { itemDescription = newDescription } + + itDb "inserts with MigrationOnly fields (#1330)" $ do + upsertWhere + (ItemMigOnly "foobar" 20 1) + [ItemMigOnlyPrice +=. 2] + [] describe "upsertManyWhere" $ do itDb "inserts fresh records" $ do diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -60,7 +60,6 @@ import qualified UniqueTest import qualified UpsertTest import qualified UpsertWhere -import qualified PgIntervalTest type Tuple = (,)