content: {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Pact.Server.History.Persistence
    ( createDB
    , insertCompletedCommand
    , queryForExisting
    , selectCompletedCommands
    , selectAllCommands
    , closeDB
    ) where
  
  
  import Control.Monad
  
  import qualified Data.Text as T
  import qualified Data.Aeson as A (eitherDecodeStrict')
  import Data.Text.Encoding (encodeUtf8)
  import Data.ByteString (ByteString)
  
  import Data.List (sortBy)
  import Data.List.Unsafe (unsafeHead)
  import Data.HashSet (HashSet)
  import qualified Data.HashSet as HashSet
  import Data.HashMap.Strict (HashMap)
  import qualified Data.HashMap.Strict as HashMap
  import Data.Maybe
  
  import Database.SQLite3.Direct
  
  import Pact.Types.Command
  import Pact.Types.Runtime
  import Pact.Types.SQLite
  
  import Pact.Server.History.Types
  
  import qualified Pact.JSON.Encode as J
  
  hashToField :: Hash -> SType
  hashToField h = SText $ Utf8 $! J.encodeStrict h
  
  hashFromField :: ByteString -> Hash
  hashFromField h = case A.eitherDecodeStrict' h of
    Left err -> error $ "hashFromField: unable to decode Hash from database! " ++ show err ++ " => " ++ show h
    Right v -> v
  
  crToField :: CommandResult Hash -> SType
  crToField r = SText $ Utf8 $! J.encodeStrict r
  
  crFromField :: ByteString -> CommandResult Hash
  crFromField cr = case A.eitherDecodeStrict' cr of
        Left err -> error $ "crFromField: unable to decode CommandResult from database! " ++ show err ++ "\n" ++ show cr
        Right v' -> v'
  
  userSigsToField :: [UserSig] -> SType
  userSigsToField us = SText $ Utf8 $! J.encodeStrict (J.Array us)
  
  userSigsFromField :: ByteString -> [UserSig]
  userSigsFromField us = case A.eitherDecodeStrict' us of
    Left err -> error $ "userSigsFromField: unable to decode [UserSigs] from database! " ++ show err ++ "\n" ++ show us
    Right v -> v
  
  gasToField :: Gas -> SType
  gasToField (Gas g) = SInt g
  
  sqlDbSchema :: Utf8
  sqlDbSchema =
    "CREATE TABLE IF NOT EXISTS 'main'.'pactCommands' \
    \( 'hash' TEXT PRIMARY KEY NOT NULL UNIQUE\
    \, 'txid' INTEGER NOT NULL\
    \, 'command' TEXT NOT NULL\
    \, 'result' TEXT NOT NULL\
    \, 'userSigs' TEXT NOT NULL\
    \, 'gas' INTEGER NOT NULL\
    \)"
  
  eitherToError :: Show e => String -> Either e a -> a
  eitherToError _ (Right v) = v
  eitherToError s (Left e) = error $ "SQLite Error in History exec: " ++ s ++ "\nWith Error: "++ show e
  
  createDB :: FilePath -> IO DbEnv
  createDB f = do
    conn' <- eitherToError "OpenDB" <$> open (Utf8 $ encodeUtf8 $ T.pack f)
    eitherToError "CreateTable" <$> exec conn' sqlDbSchema
  --  eitherToError "pragmas" <$> exec conn "PRAGMA locking_mode = EXCLUSIVE"
    DbEnv <$> pure conn'
          <*> prepStmt conn' sqlInsertHistoryRow
          <*> prepStmt conn' sqlQueryForExisting
          <*> prepStmt conn' sqlSelectCompletedCommands
          <*> prepStmt conn' sqlSelectAllCommands
  
  closeDB :: DbEnv -> IO ()
  closeDB DbEnv{..} = do
    liftEither $ closeStmt _insertStatement
    liftEither $ closeStmt _qryExistingStmt
    liftEither $ closeStmt _qryCompletedStmt
    liftEither $ closeStmt _qrySelectAllCmds
    liftEither $ close _conn
  
  sqlInsertHistoryRow :: Utf8
  sqlInsertHistoryRow =
      "INSERT INTO 'main'.'pactCommands' \
      \( 'hash'\
      \, 'txid' \
      \, 'command'\
      \, 'result'\
      \, 'userSigs'\
      \, 'gas'\
      \) VALUES (?,?,?,?,?,?)"
  
  insertRow :: Statement -> (Command ByteString, CommandResult Hash) -> IO ()
  insertRow s (Command{..},cr@CommandResult {..}) =
      execs s [hashToField (toUntypedHash _cmdHash)
              ,SInt $ fromIntegral (fromMaybe (-1) _crTxId)
              ,SText $ Utf8 _cmdPayload
              ,crToField cr
              ,userSigsToField _cmdSigs
              ,gasToField _crGas]
  
  insertCompletedCommand :: DbEnv -> [(Command ByteString, CommandResult Hash)] -> IO ()
  insertCompletedCommand DbEnv{..} v = do
    let sortCmds (_,cr1) (_,cr2) = compare (_crTxId cr1) (_crTxId cr2)
    eitherToError "start insert transaction" <$> exec _conn "BEGIN TRANSACTION"
    mapM_ (insertRow _insertStatement) $ sortBy sortCmds v
    eitherToError "end insert transaction" <$> exec _conn "END TRANSACTION"
  
  sqlQueryForExisting :: Utf8
  sqlQueryForExisting = "SELECT EXISTS(SELECT 1 FROM 'main'.'pactCommands' WHERE hash=:hash LIMIT 1)"
  
  queryForExisting :: DbEnv -> HashSet RequestKey -> IO (HashSet RequestKey)
  queryForExisting e v = foldM f v v
    where
      f s rk = do
        r <- qrys (_qryExistingStmt e) [hashToField $ unRequestKey rk] [RInt]
        case r of
          [[SInt 1]] -> return s
          _ -> return $ HashSet.delete rk s
  
  sqlSelectCompletedCommands :: Utf8
  sqlSelectCompletedCommands =
    "SELECT result,txid FROM 'main'.'pactCommands' WHERE hash=:hash LIMIT 1"
  
  selectCompletedCommands :: DbEnv -> HashSet RequestKey -> IO (HashMap RequestKey (CommandResult Hash))
  selectCompletedCommands e v = foldM f HashMap.empty v
    where
      f m rk = do
        rs <- qrys (_qryCompletedStmt e) [hashToField $ unRequestKey rk] [RText,RInt,RInt]
        if null rs
        then return m
        else case unsafeHead rs of
            [SText (Utf8 cr),SInt _, SInt _] ->
              return $ HashMap.insert rk (crFromField cr) m
            r -> dbError $ "Invalid result from query: " ++ show r
  
  sqlSelectAllCommands :: Utf8
  sqlSelectAllCommands = "SELECT hash,command,userSigs FROM 'main'.'pactCommands' ORDER BY txid ASC"
  
  selectAllCommands :: DbEnv -> IO [Command ByteString]
  selectAllCommands e = do
    let rowToCmd [SText (Utf8 hash'),SText (Utf8 cmd'),SText (Utf8 userSigs')] =
                Command { _cmdPayload = cmd'
                        , _cmdSigs = userSigsFromField userSigs'
                        , _cmdHash = fromUntypedHash $ hashFromField hash'}
        rowToCmd err = error $ "selectAllCommands: unexpected result schema: " ++ show err
    fmap rowToCmd <$> qrys_ (_qrySelectAllCmds e) [RText,RText,RText]
  