content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE GADTs #-}
  
  -- |
  -- Module      :  Pact.Native.Db
  -- Copyright   :  (C) 2016 Stuart Popejoy
  -- License     :  BSD-style (see the file LICENSE)
  -- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
  --
  -- Builtins for database access.
  --
  
  module Pact.Native.Db
      (dbDefs, checkNonLocalAllowed)
      where
  
  import Bound
  import Control.Lens hiding ((.=))
  import Control.Monad
  import Control.Monad.Reader (ask)
  import Data.Default
  import qualified Data.HashSet as HS
  import qualified Data.Map.Strict as M
  import Data.Foldable (foldlM, traverse_)
  import qualified Data.Vector as V
  import Data.Text (pack)
  
  import Pact.Eval
  import Pact.Runtime.Typecheck
  import Pact.Runtime.Utils
  import Pact.Native.Internal
  import Pact.Types.Pretty
  import Pact.Types.RowData
  import Pact.Types.Runtime
  import Pact.Types.PactValue
  import Pact.Types.KeySet (parseAnyKeysetName)
  
  class Readable a where
    readable :: a -> ReadValue
  
  instance Readable RowData where
    readable = ReadData
  instance Readable RowKey where
    readable = ReadKey
  instance Readable TxId where
    readable = const ReadTxId
  instance Readable (TxLog RowData) where
    readable = ReadData . _txValue
  instance Readable (TxId, TxLog RowData) where
    readable = ReadData . _txValue . snd
  
  -- | Parameterize calls to 'guardTable' with op.
  data GuardTableOp
    = GtRead
    | GtSelect
    | GtWithRead
    | GtWithDefaultRead
    | GtKeys
    | GtTxIds
    | GtTxLog
    | GtKeyLog
    | GtWrite
    | GtCreateTable
  
  
  dbDefs :: NativeModule
  dbDefs =
    let writeArgs part = funType tTyString
          [("table",tableTy),("key",tTyString),
           ("object",TySchema TyObject rt part)]
        writeDocs s = "Write entry in TABLE for KEY of OBJECT column data" <> s
        rt = mkSchemaVar "row"
        tableTy = TySchema TyTable rt def
        rowTy = TySchema TyObject rt def
        bindTy = TySchema TyBinding rt def
        partialize = set tySchemaPartial AnySubschema
        a = mkTyVar "a" []
        b = mkTyVar "b" []
    in ("Database",
      [setTopLevelOnly $ defGasRNative "create-table" createTable'
       (funType tTyString [("table",tableTy)])
       [LitExample "(create-table accounts)"] "Create table TABLE."
  
      ,defNative (specialForm WithRead) withRead
       (funType a [("table",tableTy),("key",tTyString),("bindings",bindTy)])
       [ LitExample "(with-read accounts id { \"balance\":= bal, \"ccy\":= ccy }\n\
         \  (format \"Balance for {} is {} {}\" [id bal ccy]))"
       ]
       "Special form to read row from TABLE for KEY and bind columns per BINDINGS over subsequent body statements."
  
      ,defNative (specialForm WithDefaultRead) withDefaultRead
       (funType a
        [("table",tableTy),("key",tTyString),("defaults",partialize rowTy),("bindings",partialize bindTy)])
       [ LitExample "(with-default-read accounts id { \"balance\": 0, \"ccy\": \"USD\" } { \"balance\":= bal, \"ccy\":= ccy }\n\
         \  (format \"Balance for {} is {} {}\" [id bal ccy]))"
       ]
       "Special form to read row from TABLE for KEY and bind columns per BINDINGS over subsequent body statements. \
       \If row not found, read columns from DEFAULTS, an object with matching key names."
  
      ,defGasRNative "read" read'
       (funType rowTy [("table",tableTy),("key",tTyString)] <>
        funType rowTy [("table",tableTy),("key",tTyString),("columns",TyList tTyString)])
       [LitExample "(read accounts id ['balance 'ccy])"]
       "Read row from TABLE for KEY, returning database record object, or just COLUMNS if specified."
  
      ,defNative (specialForm Select) select
        (funType (TyList rowTy)  [("table",tableTy),("where",TyFun $ funType' tTyBool [("row",rowTy)])] <>
         funType (TyList rowTy)  [("table",tableTy),("columns",TyList tTyString),("where",TyFun $ funType' tTyBool [("row",rowTy)])])
        [ LitExample "(select people ['firstName,'lastName] (where 'name (= \"Fatima\")))"
        , LitExample "(select people (where 'age (> 30)))?"
        ]
        "Select full rows or COLUMNS from table by applying WHERE to each row to get a boolean determining inclusion."
  
      ,defGasRNative "keys" keys'
       (funType (TyList tTyString) [("table",tableTy)])
       [LitExample "(keys accounts)"] "Return all keys in TABLE."
  
      ,defNative "fold-db" foldDB'
        (funType (TyList b)
          [ ("table", tableTy)
          , ("qry", TyFun (funType' (TyPrim TyBool) [("a", TyPrim TyString), ("b", rowTy)] ))
          , ("consumer", TyFun (funType' b [("a", TyPrim TyString), ("b", rowTy)]))])
        [LitExample "(let* \n\
                    \ ((qry (lambda (k obj) true)) ;; select all rows\n\
                    \  (f (lambda (x) [(at 'firstName x), (at 'b x)]))\n\
                    \ )\n\
                    \ (fold-db people (qry) (f))\n\
                    \)"]
        "Select rows from TABLE using QRY as a predicate with both key and value, and then accumulate results of the query \
        \in CONSUMER. Output is sorted by the ordering of keys."
      ,defGasRNative "txids" txids'
       (funType (TyList tTyInteger) [("table",tableTy),("txid",tTyInteger)])
       [LitExample "(txids accounts 123849535)"] "Return all txid values greater than or equal to TXID in TABLE."
  
      ,defNative "write" (write Write FullSchema) (writeArgs FullSchema)
       [LitExample "(write accounts id { \"balance\": 100.0 })"] (writeDocs ".")
      ,defNative "insert" (write Insert FullSchema) (writeArgs FullSchema)
       [LitExample "(insert accounts id { \"balance\": 0.0, \"note\": \"Created account.\" })"]
       (writeDocs ", failing if data already exists for KEY.")
      ,defNative "update" (write Update AnySubschema) (writeArgs AnySubschema)
       [LitExample "(update accounts id { \"balance\": (+ bal amount), \"change\": amount, \"note\": \"credit\" })"]
       (writeDocs ", failing if data does not exist for KEY.")
      ,defGasRNative "txlog" txlog
       (funType (TyList tTyObjectAny) [("table",tableTy),("txid",tTyInteger)])
        [LitExample "(txlog accounts 123485945)"] "Return all updates to TABLE performed in transaction TXID."
      ,defGasRNative "keylog" keylog
       (funType (TyList (tTyObject TyAny)) [("table",tableTy),("key",tTyString),("txid",tTyInteger)])
        [LitExample "(keylog accounts \"Alice\" 123485945)"] "Return updates to TABLE for a KEY in transactions at or after TXID, in a list of objects \
        \indexed by txid."
  
      ,setTopLevelOnly $ defRNative "describe-table" descTable
       (funType tTyObjectAny [("table",tableTy)])
       [LitExample "(describe-table accounts)"]
       "Get metadata for TABLE. Returns an object with 'name', 'hash', 'blessed', 'code', and 'keyset' fields."
      ,setTopLevelOnly $ defGasRNative "describe-keyset" descKeySet
       (funType tTyObjectAny [("keyset",tTyString)]) [] "Get metadata for KEYSET."
      ,setTopLevelOnly $ defRNative "describe-module" descModule
       (funType tTyObjectAny [("module",tTyString)])
       [LitExample "(describe-module 'my-module)"]
       "Get metadata for MODULE. Returns an object with 'name', 'hash', 'blessed', 'code', and 'keyset' fields."
      ])
  
  descTable :: RNativeFun e
  descTable _ [TTable {..}] = return $ toTObject TyAny def [
    ("name",tStr $ asString _tTableName),
    ("module", tStr $ asString _tModuleName),
    ("type", toTerm $ pack $ showPretty _tTableType)]
  descTable i as = argsError i as
  
  descKeySet :: GasRNativeFun e
  descKeySet i [TLitString t] = do
    k <- ifExecutionFlagSet FlagDisablePact44
      (pure $ KeySetName t Nothing)
      (case parseAnyKeysetName t of
         Left {} -> evalError' i "incorrect keyset name format"
         Right k -> pure k)
  
    r <- readRow (_faInfo i) KeySets k
    case r of
      Just v -> computeGas' i (GPostRead (ReadKeySet k v)) $
                return $ toTerm v
      Nothing -> evalError' i $ "Keyset not found: " <> pretty t
  descKeySet i as = argsError i as
  
  descModule :: RNativeFun e
  descModule i [TLitString t] = do
    unlessExecutionFlagSet FlagDisablePact431 $ checkNonLocalAllowed i
    mods <- lookupModule i (ModuleName t Nothing)
    case _mdModule <$> mods of
      Just m ->
        case m of
          MDModule Module{..} ->
            return $ toTObject TyAny def
              [ ("name"      , tStr $ asString _mName)
              , ("hash"      , tStr $ asString _mHash)
              , ("keyset"    , tStr $ pack $ show _mGovernance)
              , ("blessed"   , toTList tTyString def $ map (tStr . asString) (HS.toList _mBlessed))
              , ("code"      , tStr $ asString _mCode)
              , ("interfaces", toTList tTyString def $ (tStr . asString) <$> _mInterfaces)
              ]
          MDInterface Interface{..} ->
            return $ toTObject TyAny def
              [ ("name", tStr $ asString _interfaceName)
              , ("code", tStr $ asString _interfaceCode)
              ]
      Nothing -> evalError' i $ "Module not found: " <> pretty t
  descModule i as = argsError i as
  
  -- | unsafe function to create domain from TTable.
  userTable :: Show n => Term n -> Domain RowKey RowData
  userTable = UserTables . userTable'
  
  -- | unsafe function to create TableName from TTable.
  userTable' :: Show n => Term n -> TableName
  userTable' TTable {..} = TableName $ asString _tModuleName <> "_" <> asString _tTableName
  userTable' t = error $ "creating user table from non-TTable: " ++ show t
  
  
  read' :: GasRNativeFun e
  read' i as@(table@TTable {}:TLitString key:rest) = do
    cols <- case rest of
      [] -> return []
      [l] -> colsToList (argsError i as) l
      _ -> argsError i as
    guardTable i table GtRead
    mrow <- readRow (_faInfo i) (userTable table) (RowKey key)
    case mrow of
      Nothing -> failTx (_faInfo i) $ "read: row not found: " <> pretty key
      Just cs -> do
        gasPostRead i cs
        case cols of
          [] -> return $ columnsToObject (_tTableType table) cs
          _ -> columnsToObject' (_tTableType table) cols cs
  
  read' i as = argsError i as
  
  
  foldDB' :: NativeFun e
  foldDB' i [tbl, tLamToApp -> TApp qry _, tLamToApp -> TApp consumer _] = do
    table <- reduce tbl >>= \case
      t@TTable{} -> return t
      t -> isOffChainForkedError FlagDisablePact47 >>= \case
        OffChainError -> evalError' i $ "Expected table as first argument to foldDB, got: " <> pretty t
        OnChainError -> evalError' i $ "Expected table as first argument to foldDB, got argument of type: " <> pretty (typeof' t)
    computeGas (Right i) (GUnreduced [])
    computeGas (Right i) GFoldDB
    ks <- getKeys table
    xs <- foldlM (fdb table) [] ks
    pure (TList (V.fromList (reverse xs)) TyAny def)
    where
    asBool (TLiteral (LBool satisfies) _) = return satisfies
    asBool t = isOffChainForkedError FlagDisablePact47 >>= \case
      OffChainError -> evalError' i $ "Unexpected return value from fold-db query condition " <> pretty t
      OnChainError -> evalError' i $ "Unexpected return value from fold-db query condition, received value of type: " <> pretty (typeof' t)
    getKeys table = do
      guardTable i table GtKeys
      keys (_faInfo i) (userTable table)
    fdb table acc key = do
      mrow <- readRow (_faInfo i) (userTable table) key
      case mrow of
        Just row -> do
          gasPostRead i row
          let obj = columnsToObject (_tTableType table) row
          let key' = toTerm key
          cond <- asBool =<< apply qry [key', obj]
          if cond then do
            r' <- apply consumer [key', obj]
            pure (r':acc)
          else pure acc
        Nothing -> evalError (_faInfo i) $ "foldDb: unexpected error, key: "
                   <> pretty key <> " not found in table: " <> pretty table
  foldDB' i as = argsError' i as
  
  gasPostRead :: Readable r => FunApp -> r -> Eval e ()
  gasPostRead i row = computeGas (Right i) (GPostRead $ readable row)
  
  gasPostRead' :: Readable r => FunApp -> r -> Eval e a -> Eval e a
  gasPostRead' i row action = gasPostRead i row *> action
  
  -- | TODO improve post-streaming
  gasPostReads :: Readable r => FunApp -> ([r] -> a) -> Eval e [r] -> Eval e a
  gasPostReads i postProcess action = do
    rs <- action
    traverse_ (gasPostRead i) rs
    pure $ postProcess rs
  
  columnsToObject :: Type (Term Name) -> RowData -> Term Name
  columnsToObject ty m = TObject (Object (fmap (fromPactValue . rowDataToPactValue) (_rdData m)) ty def def) def
  
  columnsToObject' :: Type (Term Name) -> [(Info,FieldKey)] ->
                      RowData -> Eval m (Term Name)
  columnsToObject' ty cols (RowData _ (ObjectMap m)) = do
    ps <- forM cols $ \(ci,col) ->
                  case M.lookup col m of
                    Nothing -> evalError ci $ "read: invalid column: " <> pretty col
                    Just v -> return (col, fromPactValue $ rowDataToPactValue v)
    return $ TObject (Object (ObjectMap (M.fromList ps)) ty def def) def
  
  
  
  select :: NativeFun e
  select i as@[tbl',cols',app] = do
    cols <- reduce cols' >>= colsToList (argsError' i as)
    reduce tbl' >>= select' i as (Just cols) app
  select i as@[tbl',app] = reduce tbl' >>= select' i as Nothing app
  select i as = argsError' i as
  
  select' :: FunApp -> [Term Ref] -> Maybe [(Info,FieldKey)] ->
             Term Ref -> Term Name -> Eval e (Term Name)
  select' i _ cols' app@TApp{} tbl@TTable{} = do
      computeGas (Right i) (GUnreduced [])
      computeGas (Right i) $ GSelect cols'
      guardTable i tbl GtSelect
      let fi = _faInfo i
          tblTy = _tTableType tbl
      ks <- keys fi (userTable tbl)
      fmap (\b -> TList (V.fromList (reverse b)) tblTy def) $
        (\f -> foldM f [] ks) $ \rs k -> do
  
        mrow <- readRow fi (userTable tbl) k
        case mrow of
          Nothing -> evalError fi $ "select: unexpected error, key not found in select: "
                     <> pretty k <> ", table: " <> pretty tbl
          Just row -> do
            gasPostRead i row
            let obj = columnsToObject tblTy row
            result <- apply (_tApp app) [obj]
            case result of
              (TLiteral (LBool include) _)
                | include -> case cols' of
                    Nothing -> return (obj:rs)
                    Just cols -> (:rs) <$> columnsToObject' tblTy cols row
                | otherwise -> return rs
              t -> isOffChainForkedError FlagDisablePact47 >>= \case
                OffChainError -> evalError (_tInfo app) $ "select: filter returned non-boolean value: " <> pretty t
                OnChainError -> evalError (_tInfo app) $ "select: filter returned non-boolean value: " <> pretty (typeof' t)
  select' i as _ _ _ = argsError' i as
  
  
  withDefaultRead :: NativeFun e
  withDefaultRead fi as@[table',key',defaultRow',b@(TBinding ps bd (BindSchema _) _)] = do
    let argsToReduce = [table',key',defaultRow']
    !tkd <- gasUnreduced fi argsToReduce (mapM reduce argsToReduce)
    case tkd of
      [table@TTable {}, TLitString key, TObject (Object defaultRow _ _ _) _] -> do
        guardTable fi table GtWithDefaultRead
        mrow <- readRow (_faInfo fi) (userTable table) (RowKey key)
        case mrow of
          Nothing -> bindToRow ps bd b =<< traverse enforcePactValue defaultRow
          (Just row) -> gasPostRead' fi row $ bindToRow ps bd b (rowDataToPactValue <$> _rdData row)
      _ -> argsError' fi as
  withDefaultRead fi as = argsError' fi as
  
  withRead :: NativeFun e
  withRead fi as@[table',key',b@(TBinding ps bd (BindSchema _) _)] = do
    let argsToReduce = [table',key']
    !tk <- gasUnreduced fi argsToReduce (mapM reduce argsToReduce)
    case tk of
      [table@TTable {},TLitString key] -> do
        guardTable fi table GtWithRead
        mrow <- readRow (_faInfo fi) (userTable table) (RowKey key)
        case mrow of
          Nothing -> failTx (_faInfo fi) $ "with-read: row not found: " <> pretty key
          (Just row) -> gasPostRead' fi row $ bindToRow ps bd b (rowDataToPactValue <$> _rdData row)
      _ -> argsError' fi as
  withRead fi as = argsError' fi as
  
  bindToRow :: [BindPair (Term Ref)] ->
               Scope Int Term Ref -> Term Ref -> ObjectMap PactValue -> Eval e (Term Name)
  bindToRow ps bd b (ObjectMap row) =
    bindReduce ps bd (_tInfo b) (\s -> fromPactValue <$> M.lookup (FieldKey s) row)
  
  keys' :: GasRNativeFun e
  keys' i [table@TTable {}] = do
    gasPostReads i
      ((\b -> TList (V.fromList b) tTyString def) . map toTerm) $ do
        guardTable i table GtKeys
        keys (_faInfo i) (userTable table)
  keys' i as = argsError i as
  
  
  txids' :: GasRNativeFun e
  txids' i [table@TTable {},TLitInteger key] = do
    checkNonLocalAllowed i
    gasPostReads i
      ((\b -> TList (V.fromList b) tTyInteger def) . map toTerm) $ do
        guardTable i table GtTxIds
        txids (_faInfo i) (userTable' table) (fromIntegral key)
  txids' i as = argsError i as
  
  txlog :: GasRNativeFun e
  txlog i [table@TTable {},TLitInteger tid] = do
    checkNonLocalAllowed i
    gasPostReads i (toTList TyAny def . map txlogToObj) $ do
        guardTable i table GtTxLog
        getTxLog (_faInfo i) (userTable table) (fromIntegral tid)
  txlog i as = argsError i as
  
  txlogToObj :: TxLog RowData -> Term Name
  txlogToObj TxLog{..} = toTObject TyAny def
    [ ("table", toTerm _txDomain)
    , ("key", toTerm _txKey)
    , ("value", toTObjectMap TyAny def (fmap (fromPactValue . rowDataToPactValue) (_rdData _txValue)))
    ]
  
  checkNonLocalAllowed :: HasInfo i => i -> Eval e ()
  checkNonLocalAllowed i = do
    env <- ask
    disabledInTx <- isExecutionFlagSet FlagDisableHistoryInTransactionalMode
    let mode = view eeMode env
    when (mode == Transactional && disabledInTx) $ evalError' i $
      "Operation only permitted in local execution mode"
  
  keylog :: GasRNativeFun e
  keylog i [table@TTable {..},TLitString key,TLitInteger utid] = do
    checkNonLocalAllowed i
    let postProc = toTList TyAny def . map toTxidObj
          where toTxidObj (t,r) =
                  toTObject TyAny def [("txid", toTerm t),("value",columnsToObject _tTableType (_txValue r))]
    gasPostReads i postProc $ do
      guardTable i table GtKeyLog
      tids <- txids (_faInfo i) (userTable' table) (fromIntegral utid)
      logs <- fmap concat $ forM tids $ \tid -> map (tid,) <$> getTxLog (_faInfo i) (userTable table) tid
      return $ filter (\(_,TxLog {..}) -> _txKey == key) logs
  
  keylog i as = argsError i as
  
  write :: WriteType -> SchemaPartial -> NativeFun e
  write wt partial i as = do
    ts <- mapM reduce as
    case ts of
      [table@TTable {..},TLitString key, TObject (Object ps _ _ _) _] -> do
        ps' <- traverse enforcePactValue ps
        computeGas (Right i) (GUnreduced [])
        szVer <- getSizeOfVersion
        computeGas (Right i) (GPreWrite (WriteData wt (asString key) ps') szVer)
        guardTable i table GtWrite
        case _tTableType of
          TyAny -> return ()
          TyVar {} -> return ()
          tty -> void $ checkUserType partial (_faInfo i) ps tty
        rdv <- ifExecutionFlagSet' FlagDisablePact42 RDV0 RDV1
        success "Write succeeded" $ writeRow (_faInfo i) wt (userTable table) (RowKey key) $
            RowData rdv (pactValueToRowData <$> ps')
      _ -> argsError i ts
  
  
  createTable' :: GasRNativeFun e
  createTable' i [t@TTable {..}] = do
    guardTable i t GtCreateTable
    let (UserTables tn) = userTable t
    szVer <- getSizeOfVersion
    computeGas' i (GPreWrite (WriteTable (asString tn)) szVer) $
      success "TableCreated" $ createUserTable (_faInfo i) tn _tModuleName
  createTable' i as = argsError i as
  
  guardTable :: Pretty n => FunApp -> Term n -> GuardTableOp -> Eval e ()
  guardTable i TTable {..} dbop =
    checkLocalBypass $
      guardForModuleCall (_faInfo i) _tModuleName $
        enforceBlessedHashes i _tModuleName _tHash
    where checkLocalBypass notBypassed = do
            localBypassEnabled <- isExecutionFlagSet FlagAllowReadInLocal
            case dbop of
              GtWrite -> notBypassed
              GtCreateTable -> notBypassed
              _ | localBypassEnabled -> return ()
                | otherwise -> notBypassed
  
  guardTable i t _ = isOffChainForkedError FlagDisablePact47 >>= \case
    OffChainError -> evalError' i $ "Internal error: guardTable called with non-table term: " <> pretty t
    OnChainError -> evalError' i $ "Internal error: guardTable called with non-table term: " <> pretty (typeof' t)
  
  enforceBlessedHashes :: FunApp -> ModuleName -> ModuleHash -> Eval e ()
  enforceBlessedHashes i mn h = getModule i mn >>= \m -> case _mdModule m of
          MDModule Module{..}
            | h == _mHash -> return () -- current version ok
            | h `HS.member` _mBlessed -> return () -- hash is blessed
            | otherwise -> evalError' i $
              "Execution aborted, hash not blessed for module " <> pretty mn <> ": " <> pretty h
          _ -> evalError' i $ "Internal error: expected module reference " <> pretty mn
  