{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

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, readInt, unpack)
import qualified Data.ByteString.Lazy as L
import Data.Fixed
import Data.Foldable (asum)
import Data.Int (Int16, Int32, Int64, Int8)
import qualified Data.IntMap as IM
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import Data.Ratio (denominator, numerator)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TERR
import qualified Data.Text.Lazy as TL
import Data.Text.Read (double)
import qualified Data.Vector as V
import Data.Word (Word, Word16, Word32, Word64, Word8)
import GHC.TypeLits
import Numeric.Natural (Natural)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)

import Database.Persist.Types.Base

import Data.Time (Day (..), TimeOfDay, UTCTime, defaultTimeLocale, parseTimeM)

#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)
        ]