{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.Ledger.State.Orphans where

import Cardano.Crypto.Hash.Class
import Cardano.Ledger.Alonzo.TxBody
import Cardano.Ledger.Babbage.TxBody
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Binary
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Keys
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.PoolRank
import Cardano.Ledger.State.UTxO
import Cardano.Ledger.TxIn
import Data.ByteString.Short
import qualified Data.Text as T
import Data.Typeable
import Database.Persist
import Database.Persist.Sqlite

data SnapShotType
  = SnapShotMark
  | SnapShotSet
  | SnapShotGo
  deriving (Int -> SnapShotType -> ShowS
[SnapShotType] -> ShowS
SnapShotType -> String
(Int -> SnapShotType -> ShowS)
-> (SnapShotType -> String)
-> ([SnapShotType] -> ShowS)
-> Show SnapShotType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapShotType -> ShowS
showsPrec :: Int -> SnapShotType -> ShowS
$cshow :: SnapShotType -> String
show :: SnapShotType -> String
$cshowList :: [SnapShotType] -> ShowS
showList :: [SnapShotType] -> ShowS
Show, SnapShotType -> SnapShotType -> Bool
(SnapShotType -> SnapShotType -> Bool)
-> (SnapShotType -> SnapShotType -> Bool) -> Eq SnapShotType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapShotType -> SnapShotType -> Bool
== :: SnapShotType -> SnapShotType -> Bool
$c/= :: SnapShotType -> SnapShotType -> Bool
/= :: SnapShotType -> SnapShotType -> Bool
Eq, Int -> SnapShotType
SnapShotType -> Int
SnapShotType -> [SnapShotType]
SnapShotType -> SnapShotType
SnapShotType -> SnapShotType -> [SnapShotType]
SnapShotType -> SnapShotType -> SnapShotType -> [SnapShotType]
(SnapShotType -> SnapShotType)
-> (SnapShotType -> SnapShotType)
-> (Int -> SnapShotType)
-> (SnapShotType -> Int)
-> (SnapShotType -> [SnapShotType])
-> (SnapShotType -> SnapShotType -> [SnapShotType])
-> (SnapShotType -> SnapShotType -> [SnapShotType])
-> (SnapShotType -> SnapShotType -> SnapShotType -> [SnapShotType])
-> Enum SnapShotType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SnapShotType -> SnapShotType
succ :: SnapShotType -> SnapShotType
$cpred :: SnapShotType -> SnapShotType
pred :: SnapShotType -> SnapShotType
$ctoEnum :: Int -> SnapShotType
toEnum :: Int -> SnapShotType
$cfromEnum :: SnapShotType -> Int
fromEnum :: SnapShotType -> Int
$cenumFrom :: SnapShotType -> [SnapShotType]
enumFrom :: SnapShotType -> [SnapShotType]
$cenumFromThen :: SnapShotType -> SnapShotType -> [SnapShotType]
enumFromThen :: SnapShotType -> SnapShotType -> [SnapShotType]
$cenumFromTo :: SnapShotType -> SnapShotType -> [SnapShotType]
enumFromTo :: SnapShotType -> SnapShotType -> [SnapShotType]
$cenumFromThenTo :: SnapShotType -> SnapShotType -> SnapShotType -> [SnapShotType]
enumFromThenTo :: SnapShotType -> SnapShotType -> SnapShotType -> [SnapShotType]
Enum, SnapShotType
SnapShotType -> SnapShotType -> Bounded SnapShotType
forall a. a -> a -> Bounded a
$cminBound :: SnapShotType
minBound :: SnapShotType
$cmaxBound :: SnapShotType
maxBound :: SnapShotType
Bounded)

instance PersistField SnapShotType where
  toPersistValue :: SnapShotType -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> (SnapShotType -> Int64) -> SnapShotType -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> (SnapShotType -> Int) -> SnapShotType -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShotType -> Int
forall a. Enum a => a -> Int
fromEnum
  fromPersistValue :: PersistValue -> Either Text SnapShotType
fromPersistValue (PersistInt64 Int64
i64) = SnapShotType -> Either Text SnapShotType
forall a b. b -> Either a b
Right (SnapShotType -> Either Text SnapShotType)
-> SnapShotType -> Either Text SnapShotType
forall a b. (a -> b) -> a -> b
$ Int -> SnapShotType
forall a. Enum a => Int -> a
toEnum (Int -> SnapShotType) -> Int -> SnapShotType
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i64
  fromPersistValue PersistValue
_ = Text -> Either Text SnapShotType
forall a b. a -> Either a b
Left Text
"Unexpected type"

instance PersistFieldSql SnapShotType where
  sqlType :: Proxy SnapShotType -> SqlType
sqlType Proxy SnapShotType
_ = SqlType
SqlInt32

instance PersistField ShortByteString where
  toPersistValue :: ShortByteString -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue)
-> (ShortByteString -> ByteString)
-> ShortByteString
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
fromShort
  fromPersistValue :: PersistValue -> Either Text ShortByteString
fromPersistValue (PersistByteString ByteString
bs) = ShortByteString -> Either Text ShortByteString
forall a b. b -> Either a b
Right (ShortByteString -> Either Text ShortByteString)
-> ShortByteString -> Either Text ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ShortByteString
toShort ByteString
bs
  fromPersistValue PersistValue
_ = Text -> Either Text ShortByteString
forall a b. a -> Either a b
Left Text
"Unexpected type"

instance PersistFieldSql ShortByteString where
  sqlType :: Proxy ShortByteString -> SqlType
sqlType Proxy ShortByteString
_ = SqlType
SqlBlob

instance PersistField TxId where
  toPersistValue :: TxId -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue)
-> (TxId -> ByteString) -> TxId -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash HASH EraIndependentTxBody -> ByteString)
-> (TxId -> Hash HASH EraIndependentTxBody) -> TxId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody)
-> (TxId -> SafeHash EraIndependentTxBody)
-> TxId
-> Hash HASH EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> SafeHash EraIndependentTxBody
unTxId
  fromPersistValue :: PersistValue -> Either Text TxId
fromPersistValue (PersistByteString ByteString
bs) =
    case ByteString -> Maybe (Hash HASH EraIndependentTxBody)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
bs of
      Maybe (Hash HASH EraIndependentTxBody)
Nothing -> Text -> Either Text TxId
forall a b. a -> Either a b
Left Text
"Invalid number of bytes for the hash"
      Just Hash HASH EraIndependentTxBody
h -> TxId -> Either Text TxId
forall a b. b -> Either a b
Right (TxId -> Either Text TxId) -> TxId -> Either Text TxId
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody -> TxId
TxId (SafeHash EraIndependentTxBody -> TxId)
-> SafeHash EraIndependentTxBody -> TxId
forall a b. (a -> b) -> a -> b
$ Hash HASH EraIndependentTxBody -> SafeHash EraIndependentTxBody
forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash Hash HASH EraIndependentTxBody
h
  fromPersistValue PersistValue
_ = Text -> Either Text TxId
forall a b. a -> Either a b
Left Text
"Unexpected type"

instance PersistFieldSql TxId where
  sqlType :: Proxy TxId -> SqlType
sqlType Proxy TxId
_ = SqlType
SqlBlob

deriving instance PersistField (CompactForm Coin)

deriving instance PersistFieldSql (CompactForm Coin)

deriving instance PersistField TxIx

deriving instance PersistFieldSql TxIx

instance PersistField Coin where
  toPersistValue :: Coin -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> (Coin -> Int64) -> Coin -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> (Coin -> Integer) -> Coin -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
unCoin
  fromPersistValue :: PersistValue -> Either Text Coin
fromPersistValue (PersistInt64 Int64
i64) = Coin -> Either Text Coin
forall a b. b -> Either a b
Right (Coin -> Either Text Coin) -> Coin -> Either Text Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i64
  fromPersistValue PersistValue
_ = Text -> Either Text Coin
forall a b. a -> Either a b
Left Text
"Unexpected type"

instance PersistFieldSql Coin where
  sqlType :: Proxy Coin -> SqlType
sqlType Proxy Coin
_ = SqlType
SqlInt64

instance PersistField DeltaCoin where
  toPersistValue :: DeltaCoin -> PersistValue
toPersistValue (DeltaCoin Integer
dc) = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> Int64 -> PersistValue
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
dc
  fromPersistValue :: PersistValue -> Either Text DeltaCoin
fromPersistValue (PersistInt64 Int64
i64) = DeltaCoin -> Either Text DeltaCoin
forall a b. b -> Either a b
Right (DeltaCoin -> Either Text DeltaCoin)
-> DeltaCoin -> Either Text DeltaCoin
forall a b. (a -> b) -> a -> b
$ Integer -> DeltaCoin
DeltaCoin (Integer -> DeltaCoin) -> Integer -> DeltaCoin
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i64
  fromPersistValue PersistValue
_ = Text -> Either Text DeltaCoin
forall a b. a -> Either a b
Left Text
"Unexpected type"

instance PersistFieldSql DeltaCoin where
  sqlType :: Proxy DeltaCoin -> SqlType
sqlType Proxy DeltaCoin
_ = SqlType
SqlInt64

newtype Enc a = Enc {forall a. Enc a -> a
unEnc :: a}

instance (EncCBOR a, DecCBOR a) => PersistField (Enc a) where
  toPersistValue :: Enc a -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue)
-> (Enc a -> ByteString) -> Enc a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' (forall era. Era era => Version
eraProtVerHigh @CurrentEra) (a -> ByteString) -> (Enc a -> a) -> Enc a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Enc a -> a
forall a. Enc a -> a
unEnc
  fromPersistValue :: PersistValue -> Either Text (Enc a)
fromPersistValue = (a -> Enc a) -> Either Text a -> Either Text (Enc a)
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Enc a
forall a. a -> Enc a
Enc (Either Text a -> Either Text (Enc a))
-> (PersistValue -> Either Text a)
-> PersistValue
-> Either Text (Enc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> Either Text a
forall b. DecCBOR b => PersistValue -> Either Text b
decodePersistValue

instance (EncCBOR a, DecCBOR a) => PersistFieldSql (Enc a) where
  sqlType :: Proxy (Enc a) -> SqlType
sqlType Proxy (Enc a)
_ = SqlType
SqlBlob

decodePersistValue :: DecCBOR b => PersistValue -> Either T.Text b
decodePersistValue :: forall b. DecCBOR b => PersistValue -> Either Text b
decodePersistValue (PersistByteString ByteString
bs) =
  case Version -> ByteString -> Either DecoderError b
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' (forall era. Era era => Version
eraProtVerHigh @CurrentEra) ByteString
bs of
    Left DecoderError
err -> Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
forall a b. (a -> b) -> a -> b
$ Text
"Could not decode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (DecoderError -> String
forall a. Show a => a -> String
show DecoderError
err)
    Right b
v -> b -> Either Text b
forall a b. b -> Either a b
Right b
v
decodePersistValue PersistValue
_ = Text -> Either Text b
forall a b. a -> Either a b
Left Text
"Unexpected type"

deriving via Enc (KeyHash r) instance Typeable r => PersistField (KeyHash r)

deriving via Enc (KeyHash r) instance Typeable r => PersistFieldSql (KeyHash r)

deriving via Enc (Credential r) instance Typeable r => PersistField (Credential r)

deriving via Enc (Credential r) instance Typeable r => PersistFieldSql (Credential r)

deriving via Enc Ptr instance PersistField Ptr

deriving via Enc Ptr instance PersistFieldSql Ptr

deriving via Enc (ShelleyGovState CurrentEra) instance PersistField (ShelleyGovState CurrentEra)

deriving via Enc (ShelleyGovState CurrentEra) instance PersistFieldSql (ShelleyGovState CurrentEra)

deriving via Enc (ConwayGovState CurrentEra) instance PersistField (ConwayGovState CurrentEra)

deriving via Enc (ConwayGovState CurrentEra) instance PersistFieldSql (ConwayGovState CurrentEra)

deriving via Enc (AlonzoTxOut CurrentEra) instance PersistField (AlonzoTxOut CurrentEra)

deriving via Enc (AlonzoTxOut CurrentEra) instance PersistFieldSql (AlonzoTxOut CurrentEra)

deriving via Enc (BabbageTxOut CurrentEra) instance PersistField (BabbageTxOut CurrentEra)

deriving via Enc (BabbageTxOut CurrentEra) instance PersistFieldSql (BabbageTxOut CurrentEra)

instance DecCBOR (DState CurrentEra) where
  decCBOR :: forall s. Decoder s (DState CurrentEra)
decCBOR = Decoder s (DState CurrentEra)
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

deriving via Enc (DState CurrentEra) instance PersistField (DState CurrentEra)

deriving via Enc (DState CurrentEra) instance PersistFieldSql (DState CurrentEra)

deriving via Enc (PState CurrentEra) instance PersistField (PState CurrentEra)

deriving via Enc (PState CurrentEra) instance PersistFieldSql (PState CurrentEra)

deriving via Enc GenDelegs instance PersistField GenDelegs

deriving via Enc GenDelegs instance PersistFieldSql GenDelegs

deriving via Enc PoolParams instance PersistField PoolParams

deriving via Enc PoolParams instance PersistFieldSql PoolParams

instance DecCBOR NonMyopic where
  decCBOR :: forall s. Decoder s NonMyopic
decCBOR = Decoder s NonMyopic
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

deriving via Enc NonMyopic instance PersistField NonMyopic

deriving via Enc NonMyopic instance PersistFieldSql NonMyopic

deriving via Enc (PParams CurrentEra) instance PersistField (PParams CurrentEra)

deriving via Enc (PParams CurrentEra) instance PersistFieldSql (PParams CurrentEra)