persistent-postgresql 2.13.1.0 → 2.13.2.1
raw patch · 6 files changed
+322/−254 lines, 6 files
Files
- ChangeLog.md +12/−0
- Database/Persist/Postgresql.hs +7/−252
- Database/Persist/Postgresql/Internal.hs +284/−0
- persistent-postgresql.cabal +2/−1
- test/UpsertWhere.hs +17/−0
- test/main.hs +0/−1
ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -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 }
+ Database/Persist/Postgresql/Internal.hs view
@@ -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"++
persistent-postgresql.cabal view
@@ -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 <michael@snoyman.com>@@ -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
test/UpsertWhere.hs view
@@ -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
test/main.hs view
@@ -60,7 +60,6 @@ import qualified UniqueTest import qualified UpsertTest import qualified UpsertWhere-import qualified PgIntervalTest type Tuple = (,)