persistent-2.16.0.0: Database/Persist/Class/PersistField.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-}
module Database.Persist.Class.PersistField
( PersistField (..)
, getPersistMap
, OverflowNatural(..)
) where
import Control.Arrow (second)
import Control.Monad ((<=<))
import qualified Data.Aeson as A
import Data.ByteString.Char8 (ByteString, unpack, readInt)
import qualified Data.ByteString.Lazy as L
import Data.Fixed
import Data.Foldable (asum)
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.IntMap as IM
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Read (double)
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TERR
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Numeric.Natural (Natural)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import GHC.TypeLits
import Data.Ratio (numerator, denominator)
import Database.Persist.Types.Base
import Data.Time (Day(..), TimeOfDay, UTCTime,
parseTimeM)
import Data.Time (defaultTimeLocale)
#ifdef HIGH_PRECISION_DATE
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
#endif
-- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database.
--
-- ==== __Examples__
--
-- ===== Simple Newtype
--
-- You can use @newtype@ to add more type safety/readability to a basis type like 'ByteString'. In these cases, just derive 'PersistField' and @PersistFieldSql@:
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving #-}
--
-- newtype HashedPassword = HashedPassword 'ByteString'
-- deriving (Eq, Show, 'PersistField', PersistFieldSql)
-- @
--
-- ===== Smart Constructor Newtype
--
-- In this example, we create a 'PersistField' instance for a newtype following the "Smart Constructor" pattern.
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving #-}
-- import qualified "Data.Text" as T
-- import qualified "Data.Char" as C
--
-- -- | An American Social Security Number
-- newtype SSN = SSN 'Text'
-- deriving (Eq, Show, PersistFieldSql)
--
-- mkSSN :: 'Text' -> 'Either' 'Text' SSN
-- mkSSN t = if (T.length t == 9) && (T.all C.isDigit t)
-- then 'Right' $ SSN t
-- else 'Left' $ "Invalid SSN: " <> t
--
-- instance 'PersistField' SSN where
-- 'toPersistValue' (SSN t) = 'PersistText' t
-- 'fromPersistValue' ('PersistText' t) = mkSSN t
-- -- Handle cases where the database does not give us PersistText
-- 'fromPersistValue' x = 'Left' $ "File.hs: When trying to deserialize an SSN: expected PersistText, received: " <> T.pack (show x)
-- @
--
-- Tips:
--
-- * This file contain dozens of 'PersistField' instances you can look at for examples.
-- * Typically custom 'PersistField' instances will only accept a single 'PersistValue' constructor in 'fromPersistValue'.
-- * Internal 'PersistField' instances accept a wide variety of 'PersistValue's to accomodate e.g. storing booleans as integers, booleans or strings.
-- * If you're making a custom instance and using a SQL database, you'll also need @PersistFieldSql@ to specify the type of the database column.
class PersistField a where
toPersistValue :: a -> PersistValue
fromPersistValue :: PersistValue -> Either T.Text a
#ifndef NO_OVERLAP
instance {-# OVERLAPPING #-} PersistField [Char] where
toPersistValue = PersistText . T.pack
fromPersistValue (PersistText s) = Right $ T.unpack s
fromPersistValue (PersistByteString 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
fromPersistValue (PersistDay d) = Right $ Prelude.show d
fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d
fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d
fromPersistValue PersistNull = Left $ T.pack "Unexpected null"
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 (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
instance PersistField ByteString where
toPersistValue = PersistByteString
fromPersistValue (PersistByteString bs) = Right bs
fromPersistValue x = TE.encodeUtf8 <$> fromPersistValue x
instance PersistField T.Text where
toPersistValue = PersistText
fromPersistValue = fromPersistValueText
instance PersistField TL.Text where
toPersistValue = toPersistValue . TL.toStrict
fromPersistValue = fmap TL.fromStrict . fromPersistValue
instance PersistField Html where
toPersistValue = PersistText . TL.toStrict . renderHtml
fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue
instance PersistField Int where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue = fromPersistValueIntegral "Int" "integer"
instance PersistField Int8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue = fromPersistValueIntegral "Int8" "integer"
instance PersistField Int16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue = fromPersistValueIntegral "Int16" "integer"
instance PersistField Int32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue = fromPersistValueIntegral "Int32" "integer"
instance PersistField Int64 where
toPersistValue = PersistInt64
fromPersistValue = fromPersistValueIntegral "Int64" "integer"
fromPersistValueIntegral :: Integral a => Text -> Text -> PersistValue -> Either Text a
fromPersistValueIntegral haskellType sqlType pv = case pv of
PersistInt64 i ->
Right (fromIntegral i)
PersistDouble i ->
Right $ truncate i -- oracle
PersistRational i ->
case denominator i of
1 ->
Right $ fromIntegral $ numerator i
_denom ->
boom
PersistByteString bs ->
case readInt bs of -- oracle
Just (i,"") ->
Right $ fromIntegral i
Just (i,extra) ->
Left $ extraInputError haskellType bs i extra
Nothing ->
Left $ intParseError haskellType bs
_ ->
boom
where
boom =
Left $ fromPersistValueError haskellType sqlType pv
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 $ fromPersistValueError "Word" "integer" x
instance PersistField Word8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ fromPersistValueError "Word8" "integer" x
instance PersistField Word16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ fromPersistValueError "Word16" "integer" x
instance PersistField Word32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ fromPersistValueError "Word32" "integer" x
instance PersistField Word64 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
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 $ fromPersistValueError "Double" "double, rational, or integer" x
instance (HasResolution a) => PersistField (Fixed a) where
toPersistValue = PersistRational . toRational
fromPersistValue (PersistRational r) = Right $ fromRational r
fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string
[(a, "")] -> Right a
_ -> Left $ "Can not read " <> t <> " as Fixed"
fromPersistValue (PersistDouble d) = Right $ realToFrac d
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ fromPersistValueError "Fixed" "rational, string, double, or integer" x
instance PersistField Rational where
toPersistValue = PersistRational
fromPersistValue (PersistRational r) = Right r
fromPersistValue (PersistDouble d) = Right $ toRational d
fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string
[(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' $ 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 $ fromPersistValueError "Rational" "rational, double, string, integer, or bytestring" x
instance PersistField Bool where
toPersistValue = PersistBool
fromPersistValue (PersistBool b) = Right b
fromPersistValue (PersistInt64 i) = Right $ i /= 0
fromPersistValue (PersistByteString i) = case readInt i of
Just (0,"") -> Right False
Just (1,"") -> Right True
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
fromPersistValue (PersistDay d) = Right d
fromPersistValue (PersistInt64 i) = Right $ ModifiedJulianDay $ toInteger i
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "Day" x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "Day" x
fromPersistValue x = Left $ fromPersistValueError "Day" "day, integer, string or bytestring" x
instance PersistField TimeOfDay where
toPersistValue = PersistTimeOfDay
fromPersistValue (PersistTimeOfDay d) = Right d
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "TimeOfDay" x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "TimeOfDay" x
fromPersistValue x = Left $ fromPersistValueError "TimeOfDay" "time, string, or bytestring" x
instance PersistField UTCTime where
toPersistValue = PersistUTCTime
fromPersistValue = utcTimeFromPersistValue
#ifdef HIGH_PRECISION_DATE
utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime
utcTimeFromPersistValue (PersistUTCTime d) = Right d
utcTimeFromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i
utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t
utcTimeFromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "UTCTime" x
utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x
#else
utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime
utcTimeFromPersistValue (PersistUTCTime d) = Right d
utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t
utcTimeFromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ fromPersistValueParseError "UTCTime" x
utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x
#endif
utcTimeFromPersistText :: Text -> Either Text UTCTime
utcTimeFromPersistText t =
let x = PersistText t
s = T.unpack t
in
case NonEmpty.nonEmpty (reads s) of
Nothing ->
case asum [parse8601 s, parse8601NoTimezone s, parsePretty s, parsePrettyNoTimezone s] of
Nothing -> Left $ fromPersistValueParseError "UTCTime" x
Just x' -> Right x'
Just matches ->
-- The 'Read UTCTime' instance in newer versions of 'time' is
-- more flexible when parsing UTCTime strings and will return
-- UTCTimes with different microsecond parsings. The last result
-- here contains the parsed UTCTime with as much microsecond
-- precision parsed as posssible.
Right $ fst $ NonEmpty.last matches
where
parse8601 = parseTime' "%FT%T%QZ"
parsePretty = parseTime' "%F %T%QZ"
-- Before 2.13.3.1 persistent-sqlite was missing the timezone "Z" for UTC,
-- which was only implicit, so these functions ensure backwards-compatibility.
parse8601NoTimezone = parseTime' "%FT%T%Q"
parsePrettyNoTimezone = parseTime' "%F %T%Q"
#if MIN_VERSION_time(1,5,0)
parseTime' :: String -> String -> Maybe UTCTime
parseTime' = parseTimeM True defaultTimeLocale
#else
parseTime' :: String -> String -> Maybe UTCTime
parseTime' = parseTime defaultTimeLocale
#endif
-- | Prior to @persistent-2.11.0@, we provided an instance of
-- 'PersistField' for the 'Natural' type. This was in error, because
-- 'Natural' represents an infinite value, and databases don't have
-- reasonable types for this.
--
-- The instance for 'Natural' used the 'Int64' underlying type, which will
-- cause underflow and overflow errors. This type has the exact same code
-- in the instances, and will work seamlessly.
--
-- A more appropriate type for this is the 'Word' series of types from
-- "Data.Word". These have a bounded size, are guaranteed to be
-- non-negative, and are quite efficient for the database to store.
--
-- @since 2.11.0
newtype OverflowNatural = OverflowNatural { unOverflowNatural :: Natural }
deriving (Eq, Show, Ord, Num)
instance
TypeError
( 'Text "The instance of PersistField for the Natural type was removed."
':$$: 'Text "Please see the documentation for OverflowNatural if you want to "
':$$: 'Text "continue using the old behavior or want to see documentation on "
':$$: 'Text "why the instance was removed."
':$$: 'Text ""
':$$: 'Text "This error instance will be removed in a future release."
)
=>
PersistField Natural
where
toPersistValue = undefined
fromPersistValue = undefined
instance PersistField OverflowNatural where
toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral . unOverflowNatural
fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of
Left err -> Left $ T.replace "Int64" "OverflowNatural" err
Right int -> Right $ OverflowNatural $ fromIntegral int -- TODO use bimap?
instance PersistField a => PersistField (Maybe a) where
toPersistValue Nothing = PersistNull
toPersistValue (Just a) = toPersistValue a
fromPersistValue PersistNull = Right Nothing
fromPersistValue x = Just <$> fromPersistValue x
instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where
toPersistValue = PersistList . fmap toPersistValue
fromPersistValue (PersistList l) = fromPersistList l
fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
fromPersistValue (PersistByteString bs)
| Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values
-- 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 $ fromPersistValueError "List" "list, string, bytestring or null" x
instance PersistField a => PersistField (V.Vector a) where
toPersistValue = toPersistValue . V.toList
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
toPersistValue = PersistList . fmap toPersistValue . S.toList
fromPersistValue (PersistList list) =
S.fromList <$> fromPersistList list
fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
fromPersistValue (PersistByteString bs)
| Just values <- A.decode' (L.fromChunks [bs]) =
S.fromList <$> fromPersistList values
fromPersistValue PersistNull = Right S.empty
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]
fromPersistValue v =
case fromPersistValue v of
Right [x,y] -> (,) <$> fromPersistValue x <*> fromPersistValue y
Left e -> Left e
_ -> Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show v
instance PersistField v => PersistField (IM.IntMap v) where
toPersistValue = toPersistValue . IM.toList
fromPersistValue = fmap IM.fromList . fromPersistValue
instance PersistField v => PersistField (M.Map T.Text v) where
toPersistValue = PersistMap . fmap (second toPersistValue) . M.toList
fromPersistValue = fromPersistMap <=< getPersistMap
instance PersistField PersistValue where
toPersistValue = id
fromPersistValue = Right
fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]
fromPersistList = mapM fromPersistValue
fromPersistMap :: PersistField v
=> [(T.Text, PersistValue)]
-> Either T.Text (M.Map T.Text v)
fromPersistMap = foldShortLeft fromPersistValue [] where
-- a fold that short-circuits on Left.
foldShortLeft f = go
where
go acc [] = Right $ M.fromList acc
go acc ((k, v):kvs) =
case f v of
Left e -> Left e
Right v' -> go ((k,v'):acc) kvs
-- | FIXME Add documentation to that.
getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]
getPersistMap (PersistMap kvs) = Right kvs
getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t)
getPersistMap (PersistByteString bs)
| Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs
getPersistMap PersistNull = Right []
getPersistMap x = Left $ fromPersistValueError "[(Text, PersistValue)]" "map, string, bytestring or null" x
instance PersistField Checkmark where
toPersistValue Active = PersistBool True
toPersistValue Inactive = PersistNull
fromPersistValue PersistNull = Right Inactive
fromPersistValue (PersistBool True) = Right Active
fromPersistValue (PersistInt64 1) = Right Active
fromPersistValue (PersistByteString i) = case readInt i of
Just (0,"") -> Left "Failed to parse Haskell type `Checkmark`: found `0`, expected `1` or NULL"
Just (1,"") -> Right Active
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 $ 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)
]