persistent 2.7.3 → 2.7.3.1
raw patch · 5 files changed
+110/−47 lines, 5 files
Files
- ChangeLog.md +6/−0
- Database/Persist/Class/PersistField.hs +99/−42
- Database/Persist/Class/PersistUnique.hs +2/−2
- Database/Persist/Sql/Orphan/PersistStore.hs +2/−2
- persistent.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,9 @@+## 2.7.3.1+ + * Improve error messages when failing to parse database results into Persistent records. [#741](https://github.com/yesodweb/persistent/pull/741)+ * A handful of `fromPersistField` implementations called `error` instead of returning a `Left Text`. All of the implementations were changed to return `Left`. [#741](https://github.com/yesodweb/persistent/pull/741)+ * Improve error message when a SQL insert fails with a custom primary key [#757](https://github.com/yesodweb/persistent/pull/757)+ ## 2.7.3 * Reverts [#723](https://github.com/yesodweb/persistent/pull/723), which generalized functions using the `BackendCompatible` class. These changes were an accidental breaking change.
Database/Persist/Class/PersistField.hs view
@@ -43,9 +43,6 @@ import Control.Monad ((<=<)) -import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T- import qualified Data.Aeson as A import qualified Data.Set as S@@ -53,6 +50,7 @@ import qualified Data.IntMap as IM import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TERR import qualified Data.Vector as V #if MIN_VERSION_time(1,5,0)@@ -79,7 +77,7 @@ toPersistValue = PersistText . T.pack fromPersistValue (PersistText s) = Right $ T.unpack s fromPersistValue (PersistByteString bs) =- Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs+ Right $ T.unpack $ TE.decodeUtf8With TERR.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ Prelude.show i fromPersistValue (PersistDouble d) = Right $ Prelude.show d fromPersistValue (PersistRational r) = Right $ Prelude.show r@@ -97,7 +95,7 @@ instance PersistField ByteString where toPersistValue = PersistByteString fromPersistValue (PersistByteString bs) = Right bs- fromPersistValue x = T.encodeUtf8 A.<$> fromPersistValue x+ fromPersistValue x = TE.encodeUtf8 A.<$> fromPersistValue x instance PersistField T.Text where toPersistValue = PersistText@@ -115,7 +113,7 @@ toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle- fromPersistValue x = Left $ T.pack $ "int Expected Integer, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Int" "integer" x instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral@@ -123,8 +121,9 @@ fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i- xs -> error $ "PersistField Int8 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]"- fromPersistValue x = Left $ T.pack $ "int8 Expected Integer, received: " ++ show x+ Just (i,extra) -> Left $ extraInputError "Int64" bs i extra+ Nothing -> Left $ intParseError "Int64" bs+ fromPersistValue x = Left $ fromPersistValueError "Int8" "integer" x instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral@@ -132,8 +131,9 @@ fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i- xs -> error $ "PersistField Int16 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]"- fromPersistValue x = Left $ T.pack $ "int16 Expected Integer, received: " ++ show x+ Just (i,extra) -> Left $ extraInputError "Int64" bs i extra+ Nothing -> Left $ intParseError "Int64" bs+ fromPersistValue x = Left $ fromPersistValueError "Int16" "integer" x instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral@@ -141,8 +141,9 @@ fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i- xs -> error $ "PersistField Int32 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]"- fromPersistValue x = Left $ T.pack $ "int32 Expected Integer, received: " ++ show x+ Just (i,extra) -> Left $ extraInputError "Int64" bs i extra+ Nothing -> Left $ intParseError "Int64" bs+ fromPersistValue x = Left $ fromPersistValueError "Int32" "integer" x instance PersistField Int64 where toPersistValue = PersistInt64 . fromIntegral@@ -150,40 +151,68 @@ fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i- xs -> error $ "PersistField Int64 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]"- fromPersistValue x = Left $ T.pack $ "int64 Expected Integer, received: " ++ show x+ Just (i,extra) -> Left $ extraInputError "Int64" bs i extra+ Nothing -> Left $ intParseError "Int64" bs+ fromPersistValue x = Left $ fromPersistValueError "Int64" "integer" x +extraInputError :: (Show result)+ => Text -- ^ Haskell type+ -> ByteString -- ^ Original bytestring+ -> result -- ^ Integer result+ -> ByteString -- ^ Extra bytestring+ -> Text -- ^ Error message+extraInputError haskellType original result extra = T.concat+ [ "Parsed "+ , TE.decodeUtf8 original+ , " into Haskell type `"+ , haskellType+ , "` with value"+ , T.pack $ show result+ , "but had extra input: "+ , TE.decodeUtf8 extra+ ]++intParseError :: Text -- ^ Haskell type+ -> ByteString -- ^ Original bytestring+ -> Text -- ^ Error message+intParseError haskellType original = T.concat+ [ "Failed to parse Haskell type `"+ , haskellType+ , " from "+ , TE.decodeUtf8 original+ ]+ instance PersistField Data.Word.Word where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Word" "integer" x instance PersistField Word8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Word8" "integer" x instance PersistField Word16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Word16" "integer" x instance PersistField Word32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Word32" "integer" x instance PersistField Word64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x instance PersistField Double where toPersistValue = PersistDouble fromPersistValue (PersistDouble d) = Right d fromPersistValue (PersistRational r) = Right $ fromRational r fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Double, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Double" "double, rational, or integer" x instance (HasResolution a) => PersistField (Fixed a) where toPersistValue = PersistRational . toRational@@ -193,7 +222,7 @@ _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "PersistField Fixed:Expected Rational, received: " <> T.pack (show x)+ fromPersistValue x = Left $ fromPersistValueError "Fixed" "rational, string, double, or integer" x instance PersistField Rational where toPersistValue = PersistRational@@ -203,11 +232,11 @@ [(a, "")] -> Right $ toRational (a :: Pico) _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistByteString bs) = case double $ T.cons '0' $ T.decodeUtf8With T.lenientDecode bs of+ fromPersistValue (PersistByteString bs) = case double $ T.cons '0' $ TE.decodeUtf8With TERR.lenientDecode bs of Right (ret,"") -> Right $ toRational ret Right (a,b) -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show (a,b)) Left xs -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show xs)- fromPersistValue x = Left $ "PersistField Rational:Expected Rational, received: " <> T.pack (show x)+ fromPersistValue x = Left $ fromPersistValueError "Rational" "rational, double, string, integer, or bytestring" x instance PersistField Bool where toPersistValue = PersistBool@@ -216,8 +245,8 @@ fromPersistValue (PersistByteString i) = case readInt i of Just (0,"") -> Right False Just (1,"") -> Right True- xs -> error $ "PersistField Bool failed parsing PersistByteString xs["++show xs++"] i["++show i++"]"- fromPersistValue x = Left $ T.pack $ "Expected Bool, received: " ++ show x+ xs -> Left $ T.pack $ "Failed to parse Haskell type `Bool` from PersistByteString. Original value:" ++ show i ++ ". Parsed by `readInt` as " ++ (show xs) ++ ". Expected '1'."+ fromPersistValue x = Left $ fromPersistValueError "Bool" "boolean, integer, or bytestring of '1' or '0'" x instance PersistField Day where toPersistValue = PersistDay@@ -226,12 +255,12 @@ fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d- _ -> Left $ T.pack $ "Expected Day, received " ++ show x+ _ -> Left $ fromPersistValueParseError "Day" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d- _ -> Left $ T.pack $ "Expected Day, received " ++ show x- fromPersistValue x = Left $ T.pack $ "Expected Day, received: " ++ show x+ _ -> Left $ fromPersistValueParseError "Day" x+ fromPersistValue x = Left $ fromPersistValueError "Day" "day, integer, string or bytestring" x instance PersistField TimeOfDay where toPersistValue = PersistTimeOfDay@@ -239,12 +268,12 @@ fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d- _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x+ _ -> Left $ fromPersistValueParseError "TimeOfDay" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d- _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x- fromPersistValue x = Left $ T.pack $ "Expected TimeOfDay, received: " ++ show x+ _ -> Left $ fromPersistValueParseError "TimeOfDay" x+ fromPersistValue x = Left $ fromPersistValueError "TimeOfDay" "time, string, or bytestring" x instance PersistField UTCTime where toPersistValue = PersistUTCTime@@ -257,7 +286,7 @@ (d, _):_ -> Right d _ -> case parse8601 $ T.unpack t of- Nothing -> Left $ T.pack $ "Expected UTCTime, received " ++ show x+ Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x' where #if MIN_VERSION_time(1,5,0)@@ -268,14 +297,16 @@ fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d- _ -> Left $ T.pack $ "Expected UTCTime, received " ++ show x+ _ -> Left $ fromPersistValueParseError "UTCTime" x - fromPersistValue x = Left $ T.pack $ "Expected UTCTime, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x #if MIN_VERSION_base(4,8,0) instance PersistField Natural where toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral- fromPersistValue x = fromIntegral <$> (fromPersistValue x :: Either Text Int64)+ fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of+ Left err -> Left $ T.replace "Int64" "Natural" err+ Right int -> Right $ fromIntegral int -- TODO use bimap? #endif instance PersistField a => PersistField (Maybe a) where@@ -297,11 +328,11 @@ -- avoid the need for a migration to fill in empty lists. -- also useful when Persistent is not the only one filling in the data fromPersistValue (PersistNull) = Right []- fromPersistValue x = Left $ T.pack $ "Expected PersistList, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "List" "list, string, bytestring or null" x instance PersistField a => PersistField (V.Vector a) where toPersistValue = toPersistValue . V.toList- fromPersistValue = either (\e -> Left ("Vector: " `T.append` e))+ fromPersistValue = either (\e -> Left ("Failed to parse Haskell type `Vector`: " `T.append` e)) (Right . V.fromList) . fromPersistValue instance (Ord a, PersistField a) => PersistField (S.Set a) where@@ -313,7 +344,7 @@ | Just values <- A.decode' (L.fromChunks [bs]) = S.fromList <$> fromPersistList values fromPersistValue PersistNull = Right S.empty- fromPersistValue x = Left $ T.pack $ "Expected PersistSet, received: " ++ show x+ fromPersistValue x = Left $ fromPersistValueError "Set" "list, string, bytestring or null" x instance (PersistField a, PersistField b) => PersistField (a,b) where toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y]@@ -358,7 +389,7 @@ getPersistMap (PersistByteString bs) | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs getPersistMap PersistNull = Right []-getPersistMap x = Left $ T.pack $ "Expected PersistMap, received: " ++ show x+getPersistMap x = Left $ fromPersistValueError "[(Text, PersistValue)]" "map, string, bytestring or null" x data SomePersistField = forall a. PersistField a => SomePersistField a instance PersistField SomePersistField where@@ -372,10 +403,36 @@ fromPersistValue (PersistBool True) = Right Active fromPersistValue (PersistInt64 1) = Right Active fromPersistValue (PersistByteString i) = case readInt i of- Just (0,"") -> Left $ T.pack "PersistField Checkmark: found unexpected 0 value"+ Just (0,"") -> Left "Failed to parse Haskell type `Checkmark`: found `0`, expected `1` or NULL" Just (1,"") -> Right Active- xs -> Left $ T.pack $ "PersistField Checkmark failed parsing PersistByteString xs["++show xs++"] i["++show i++"]"+ xs -> Left $ T.pack $ "Failed to parse Haskell type `Checkmark` from PersistByteString. Original value:" ++ show i ++ ". Parsed by `readInt` as " ++ (show xs) ++ ". Expected '1'." fromPersistValue (PersistBool False) = Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" fromPersistValue other =- Left $ T.pack $ "PersistField Checkmark: unknown value " ++ show other+ Left $ fromPersistValueError "Checkmark" "boolean, integer, bytestring or null" other+++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."+ ]++fromPersistValueParseError :: (Show a)+ => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"+ -> a -- ^ Received value+ -> Text -- ^ Error message+fromPersistValueParseError haskellType received = T.concat+ [ "Failed to parse Haskell type `"+ , haskellType+ , "`, but received "+ , T.pack (show received)+ ]
Database/Persist/Class/PersistUnique.hs view
@@ -76,7 +76,7 @@ -- * insert the new record if it does not exist; -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. --- -- Throws an exception if there is more than 1 uniqueness contraint.+ -- Throws an exception if there is more than 1 uniqueness constraint. upsert :: (MonadIO m, PersistRecordBackend record backend) => record -- ^ new record to insert@@ -90,7 +90,7 @@ -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist;- -- * update the existing record that matches the given uniqueness contraint.+ -- * update the existing record that matches the given uniqueness constraint. upsertBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -- ^ uniqueness constraint to find by
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -163,7 +163,7 @@ Right k -> return k Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> case keyFromValues vals' of- Left _ -> error $ "Invalid result from a SQL insert, got: " ++ show vals'+ Left e -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ++ ". Error was: " ++ unpack e Right k -> return k ISRInsertGet sql1 sql2 -> do@@ -320,7 +320,7 @@ Nothing -> return Nothing Just vals -> case fromPersistValues $ if noColumns then [] else vals of- Left e -> error $ "get " ++ show k ++ ": " ++ unpack e+ Left e -> error $ "Error when calling `get` with key: " ++ show k ++ ". Failed to create `" ++ (unpack (unHaskellName $ entityHaskell t)) ++ "` because of error: " ++ unpack e ++ " Potential solution: If your field is using a custom PersistField instance, check that it's correct." Right v -> return $ Just v instance PersistStoreRead SqlReadBackend where get k = withReaderT persistBackend $ get k
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.7.3+version: 2.7.3.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>