{-# LANGUAGE GADTs #-}

-- | Transaction metadata conform the wallet specification
module Cardano.Wallet.Kernel.DB.TxMeta.Types (
    -- * Transaction metadata
    TxMeta(..)

    -- ** Lenses
  , txMetaId
  , txMetaAmount
  , txMetaInputs
  , txMetaOutputs
  , txMetaCreationAt
  , txMetaIsLocal
  , txMetaIsOutgoing
  , txMetaWalletId
  , txMetaAccountIx

  -- * Transaction storage
  , MetaDBHandle (..)

  -- * Filtering and sorting primitives
  , AccountFops (..)
  , FilterOperation (..)
  , FilterOrdering (..)
  , Limit (..)
  , Offset (..)
  , Sorting (..)
  , SortCriteria (..)
  , SortDirection (..)

  -- * Domain-specific errors
  , TxMetaStorageError (..)
  , InvariantViolation (..)

  -- * Strict & lenient equalities
  , exactlyEqualTo
  , isomorphicTo
  , txIdIsomorphic

  -- * Internals useful for testing
  , uniqueElements
  , quadF
  , PutReturn (..)
  ) where

import           Universum

import           Control.Lens.TH (makeLenses)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Text.Lazy.Builder as B
import           Formatting (bprint, shown, (%))
import qualified Formatting as F
import           Formatting.Buildable (build)
import           Pos.Crypto (shortHashF)
import           Serokell.Util.Text (listBuilderJSON, listJsonIndent,
                     mapBuilder)
import           Test.QuickCheck (Arbitrary (..), Gen)

import qualified Pos.Chain.Txp as Txp
import qualified Pos.Core as Core

import           Test.Pos.Core.Arbitrary ()

{-------------------------------------------------------------------------------
  Transaction metadata
-------------------------------------------------------------------------------}

-- | Transaction metadata

--
-- NOTE: This does /not/ live in the acid-state database (and consequently
-- does not need a 'SafeCopy' instance), because this will grow without bound.
data TxMeta = TxMeta {
      -- | Transaction ID
      _txMetaId         :: Txp.TxId

      -- | Total amount
    , _txMetaAmount     :: Core.Coin

      -- | Transaction inputs
    , _txMetaInputs     :: NonEmpty (Txp.TxId, Word32, Core.Address, Core.Coin)

      -- | Transaction outputs
    , _txMetaOutputs    :: NonEmpty (Core.Address, Core.Coin)

      -- | Transaction creation time
    , _txMetaCreationAt :: Core.Timestamp

      -- | Is this a local transaction?
      --
      -- A transaction is local when /all/ of its inputs and outputs are
      -- to and from addresses owned by this wallet.
    , _txMetaIsLocal    :: Bool

      -- | Is this an outgoing transaction?
      --
      -- A transaction is outgoing when it decreases the wallet's balance.
    , _txMetaIsOutgoing :: Bool

      -- The Wallet that added this Tx.
    , _txMetaWalletId   :: Core.Address

      -- The account index that added this Tx
    , _txMetaAccountIx  :: Word32
    } deriving Show

makeLenses ''TxMeta

-- | Strict equality for two 'TxMeta': two 'TxMeta' are equal if they have
-- exactly the same data, and inputs & outputs needs to appear in exactly
-- the same order.
exactlyEqualTo :: TxMeta -> TxMeta -> Bool
exactlyEqualTo t1 t2 =
    and [ t1 ^. txMetaId == t2 ^. txMetaId
        , t1 ^. txMetaAmount == t2 ^. txMetaAmount
        , t1 ^. txMetaInputs  == t2 ^. txMetaInputs
        , t1 ^. txMetaOutputs == t2 ^. txMetaOutputs
        , t1 ^. txMetaCreationAt == t2 ^. txMetaCreationAt
        , t1 ^. txMetaIsLocal == t2 ^. txMetaIsLocal
        , t1 ^. txMetaIsOutgoing == t2 ^. txMetaIsOutgoing
        , t1 ^. txMetaWalletId == t2 ^. txMetaWalletId
        , t1 ^. txMetaAccountIx == t2 ^. txMetaAccountIx
        ]

-- | Lenient equality for two 'TxMeta': two 'TxMeta' are equal if they have
-- the same data, same outputs in the same order and same inputs even if in different order.
-- NOTE: This check might be slightly expensive as it's nlogn in the
-- number of inputs, as it requires sorting.
isomorphicTo :: TxMeta -> TxMeta -> Bool
isomorphicTo t1 t2 =
    and [ t1 ^. txMetaId == t2 ^. txMetaId
        , t1 ^. txMetaAmount == t2 ^. txMetaAmount
        , NonEmpty.sort (t1 ^. txMetaInputs)  == NonEmpty.sort (t2 ^. txMetaInputs)
        , t1 ^. txMetaOutputs == t2 ^. txMetaOutputs
        , t1 ^. txMetaCreationAt == t2 ^. txMetaCreationAt
        , t1 ^. txMetaIsLocal == t2 ^. txMetaIsLocal
        , t1 ^. txMetaIsOutgoing == t2 ^. txMetaIsOutgoing
        , t1 ^. txMetaWalletId == t2 ^. txMetaWalletId
        , t1 ^. txMetaAccountIx == t2 ^. txMetaAccountIx
        ]

-- This means TxMeta have same Inputs and TxId.
txIdIsomorphic :: TxMeta -> TxMeta -> Bool
txIdIsomorphic t1 t2 =
    and [ t1 ^. txMetaId == t2 ^. txMetaId
        , NonEmpty.sort (t1 ^. txMetaInputs)  == NonEmpty.sort (t2 ^. txMetaInputs)
        , t1 ^. txMetaOutputs == t2 ^. txMetaOutputs
        ]

type AccountIx = Word32
type WalletId = Core.Address
-- | Filter Operations on Accounts. This is hiererchical: you can`t have AccountIx without WalletId.
data AccountFops = Everything | AccountFops WalletId (Maybe AccountIx)

data InvariantViolation =
        TxIdInvariantViolated Txp.TxId
        -- ^ When attempting to insert a new 'MetaTx', the TxId
        -- identifying this transaction was already present in the storage,
        -- but with different values (i.e. different inputs/outputs etc)
        -- and this is effectively an invariant violation.
      | UndisputableLookupFailed Text
        -- ^ The db works in a try-catch style: it always first tries to
        -- insert data and if the PrimaryKey is already there, we catch the
        -- exception and do the lookup. This lookup should never fail, because
        -- the db is append only and if it`s found once, it should always
        -- be there.
      deriving Show

-- | A domain-specific collection of things which might go wrong when
-- storing & retrieving 'TxMeta' from a persistent storage.
data TxMetaStorageError =
      InvariantViolated InvariantViolation
    -- ^ One of the invariant was violated.
    | StorageFailure SomeException
    -- ^ The underlying storage failed to fulfill the request.
    deriving Show

instance Exception TxMetaStorageError

instance Buildable TxMetaStorageError where
    build storageErr = bprint shown storageErr

-- | Generates 'NonEmpty' collections which do not contain duplicates.
-- Limit the size to @size@ elements. @size@ should be > 0.
uniqueElements :: (Arbitrary a, Ord a) => Int -> Gen (NonEmpty a)
uniqueElements 0 = error "should have size > 0"
uniqueElements size = do
    (NonEmpty.fromList . Set.toList) <$> (go mempty)
    where
      go st = if (Set.size st == size)
        then return st
        else do
          a <- arbitrary
          go (Set.insert a st)

instance Buildable TxMeta where
    build txMeta = bprint (" id = "%shortHashF%
                           " amount = " % F.build %
                           " inputs = " % F.later tQuadBuilder %
                           " outputs = " % F.later mapBuilder %
                           " creationAt = " % F.build %
                           " isLocal = " % F.build %
                           " isOutgoing = " % F.build %
                           " walletId = " % F.build %
                           " accountIx = " % F.build
                          ) (txMeta ^. txMetaId)
                            (txMeta ^. txMetaAmount)
                            (txMeta ^. txMetaInputs)
                            (txMeta ^. txMetaOutputs)
                            (txMeta ^. txMetaCreationAt)
                            (txMeta ^. txMetaIsLocal)
                            (txMeta ^. txMetaIsOutgoing)
                            (txMeta ^. txMetaWalletId)
                            (txMeta ^. txMetaAccountIx)

tQuadBuilder
    :: (Traversable t, Buildable a, Buildable b, Buildable c, Buildable d)
    => t (a, b, c, d) -> B.Builder
tQuadBuilder = listBuilderJSON . fmap quadBuilder

quadBuilder
    :: (Buildable a, Buildable b, Buildable c, Buildable d)
    => (a, b, c, d) -> B.Builder
quadBuilder (a, b, c, d) = bprint ("(" % F.build % ", " % F.build % ", "
      % F.build % ", " % F.build % ")") a b c d

quadF :: (Buildable a, Buildable b, Buildable c, Buildable d) => F.Format r ((a,b,c,d) -> r)
quadF = F.later quadBuilder

instance Buildable [TxMeta] where
    build txMeta = bprint ("TxMetas: "%listJsonIndent 4) txMeta


-- | Basic filtering & sorting types.

newtype Offset = Offset { getOffset :: Integer }

newtype Limit  = Limit  { getLimit  :: Integer }

data SortDirection =
      Ascending
    | Descending

data Sorting = Sorting {
      sbCriteria  :: SortCriteria
    , sbDirection :: SortDirection
    }

data SortCriteria =
      SortByCreationAt
    -- ^ Sort by the creation time of this 'Kernel.TxMeta'.
    | SortByAmount
    -- ^ Sort the 'TxMeta' by the amount of money they hold.

data FilterOperation a =
    NoFilterOp
    -- ^ No filter operation provided
    | FilterByIndex a
    -- ^ Filter by index (e.g. equal to)
    | FilterByPredicate FilterOrdering a
    -- ^ Filter by predicate (e.g. lesser than, greater than, etc.)
    | FilterByRange a a
    -- ^ Filter by range, in the form [from,to]
    | FilterIn [a]
    deriving (Show, Eq)

data FilterOrdering =
      Equal
    | GreaterThan
    | GreaterThanEqual
    | LesserThan
    | LesserThanEqual
    deriving (Show, Eq, Enum, Bounded)

-- This is used mainly for testing and indicates, what happening
-- at the internals of SQlite during a putTxMetaT operation
-- @Tx@ means a new Tx was inserted
-- @Meta@ means the Tx was there but from a different Account, so a new TxMeta entry was created.
-- @No@ means the Tx was there from the same Account. This means nothing happens internally.
data PutReturn = Tx | Meta | No
    deriving (Show, Eq, Enum, Bounded)

instance Buildable PutReturn where
  build ret = bprint shown ret

-- | An opaque handle to the underlying storage, which can be easily instantiated
-- to a more concrete implementation like a Sqlite database, or even a pure
-- K-V store.
data MetaDBHandle = MetaDBHandle {
      closeMetaDB   :: IO ()
    , migrateMetaDB :: IO ()
    , clearMetaDB   :: IO ()
    , deleteTxMetas :: Core.Address -> Maybe Word32 -> IO ()
    , getTxMeta     :: Txp.TxId -> Core.Address -> Word32 -> IO (Maybe TxMeta)
    , putTxMeta     :: TxMeta -> IO ()
    , putTxMetaT    :: TxMeta -> IO PutReturn
    , getAllTxMetas :: IO [TxMeta]
    , getTxMetas    :: Offset -- Pagination: the starting offset of results.
                    -> Limit  -- An upper limit of the length of [TxMeta] returned.
                    -> AccountFops -- Filters on the Account. This may specidy an Account or a Wallet.
                    -> Maybe Core.Address -- Filters on the Addres.
                    -> FilterOperation Txp.TxId -- Filters on the TxId of the Tx.
                    -> FilterOperation Core.Timestamp -- Filters on the creation timestamp of the Tx.
                    -> Maybe Sorting -- Sorting of the results.
                    -> IO ([TxMeta], Maybe Int) -- the result in the form (results, totalEntries).
                                                -- totalEntries may be Nothing, because counting can
                                                -- be an expensive operation.
    }
