{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module Pact.Server.History.Service
  ( initHistoryEnv
  , runHistoryService
  , setupPersistence
  , addNewKeys
  , updateExistingKeys
  , queryForResults
  ) where

import Control.Lens hiding (Index)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.RWS.Strict
import Control.Concurrent.MVar
import System.Directory

import Data.ByteString (ByteString)
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 (fromJust)
import Data.Default

import Pact.Types.Command
import Pact.Types.Hash
import Pact.Types.Server
import Pact.Types.Term
import Pact.Server.History.Types
import Pact.Server.History.Persistence as DB
import Pact.Types.Runtime (PactError(..),PactErrorType(..))
import Pact.Types.Pretty (viaShow)


initHistoryEnv
  :: HistoryChannel
  -> InboundPactChan
  -> Maybe FilePath
  -> (String -> IO ())
  -> ReplayFromDisk
  -> HistoryEnv
initHistoryEnv historyChannel' inboundPactChannel' dbPath' debugPrint' rp = HistoryEnv
  { _historyChannel = historyChannel'
  , _inboundPactChannel = inboundPactChannel'
  , _debugPrint = debugPrint'
  , _dbPath = dbPath'
  , _replayFromDisk = rp
  }

runHistoryService :: HistoryEnv -> Maybe HistoryState -> IO ()
runHistoryService env mState = do
  let dbg = env ^. debugPrint
  let oChan = env ^. historyChannel
  initHistoryState <- case mState of
    Nothing -> do
      pers <- setupPersistence dbg (env ^. dbPath) (env ^. replayFromDisk)
      return $! HistoryState { _registeredListeners = HashMap.empty, _persistence = pers }
    Just mState' -> do
      return mState'
  (_,bouncedState,_) <- runRWST (handle oChan) env initHistoryState
  runHistoryService env (Just bouncedState)

debug :: String -> HistoryService ()
debug s = do
  dbg <- view debugPrint
  liftIO $! dbg $ "[history] " ++ s

setupPersistence :: (String -> IO ()) -> Maybe FilePath -> ReplayFromDisk -> IO PersistenceSystem
setupPersistence dbg Nothing (ReplayFromDisk rp) = do
  dbg "[history] Persistence Disabled"
  putMVar rp [] -- if there's no replays, we still need to unblock the cmd thread
  return $ InMemory HashMap.empty
setupPersistence dbg (Just dbPath') (ReplayFromDisk rp) = do
  let dbfile = dbPath' ++ "/commands.sqlite"
  dbg $ "[history] Persistence Enabled: " ++ dbfile
  dbExists <- doesFileExist dbfile
  conn <- DB.createDB dbfile
  when dbExists $ do
    replayFromDisk' <- DB.selectAllCommands conn
    dbg "[history] Replaying from disk"
    putMVar rp replayFromDisk'
  unless dbExists $
    putMVar rp [] -- if there's no replays, we still need to unblock the cmd thread
  return OnDisk { incompleteRequestKeys = HashMap.empty
                , dbConn = conn }

handle :: HistoryChannel -> HistoryService ()
handle oChan = do
  q <- liftIO $ readHistory oChan
  case q of
    AddNew{..} -> addNewKeys hNewKeys
    Update{..} -> updateExistingKeys hUpdateRks
    QueryForResults{..} -> queryForResults hQueryForResults
    RegisterListener{..} -> registerNewListeners hNewListener

addNewKeys :: [Command ByteString] -> HistoryService ()
addNewKeys cmds = do
  pers <- use persistence
  let writeNewCmds newCmdsHM = do
        newCmdsList <- return $ filter (\cmd -> HashMap.member (cmdToRequestKey cmd) newCmdsHM) cmds
        pactChan <- view inboundPactChannel
        liftIO $ writeInbound pactChan (TxCmds newCmdsList)
  case pers of
    InMemory m -> do
      asHM <- return $ HashMap.fromList $! (\cmd -> (cmdToRequestKey cmd,(cmd, Nothing))) <$> cmds
      newCmdsHM <- return $ HashMap.difference asHM m
      writeNewCmds newCmdsHM
      persistence .= InMemory (HashMap.union m newCmdsHM)
    OnDisk{..} -> do
      asHM <- return $ HashMap.fromList $! (\cmd -> (cmdToRequestKey cmd,cmd)) <$> cmds
      notInMem <- return $ HashMap.difference asHM incompleteRequestKeys
      if HashMap.null notInMem
      -- unlikely but worth a O(1) check
      then do
        debug $ "Each of the " ++ show (HashMap.size asHM) ++ " new command(s) had a previously seen hash/requestKey"
      else do
        foundOnDisk <- liftIO $ DB.queryForExisting dbConn $ HashSet.fromMap $ void notInMem
        newCmdsHM <- return $ HashMap.filterWithKey (\k _ -> not $ HashSet.member k foundOnDisk) notInMem
        if HashMap.null newCmdsHM
        then do
          debug $ "Each of the " ++ show (HashMap.size asHM) ++ " new command(s) had a previously hash/requestKey"
        else do
          writeNewCmds newCmdsHM
          persistence .= OnDisk { incompleteRequestKeys = HashMap.union incompleteRequestKeys newCmdsHM
                                , dbConn = dbConn }
          debug $ "Added " ++ show (HashMap.size newCmdsHM) ++ " new command(s)"
          when (HashMap.size asHM /= HashMap.size newCmdsHM) $ do
            debug $ "Some (" ++ show (HashMap.size asHM - HashMap.size newCmdsHM) ++ ") new command(s) had a previously seen hash/requestKey"


updateExistingKeys :: HashMap RequestKey (CommandResult Hash)-> HistoryService ()
updateExistingKeys updates = do
  alertListeners updates
  pers <- use persistence
  case pers of
    InMemory m -> do
      newInMem <- return $! InMemory $! foldr updateInMemKey m $ HashMap.toList updates
      persistence .= newInMem
    OnDisk{..} -> do
      pairedCmdResults <- return $ pairResultWithCmd incompleteRequestKeys <$> HashMap.toList updates
      liftIO $ DB.insertCompletedCommand dbConn pairedCmdResults
      persistence .= OnDisk { incompleteRequestKeys = HashMap.filterWithKey (\k _ -> not $ HashMap.member k updates) incompleteRequestKeys
                            , dbConn = dbConn }
  debug $ "Updated " ++ show (HashMap.size updates) ++ " command(s)"

updateInMemKey :: (RequestKey, CommandResult Hash) ->
                  HashMap RequestKey (Command ByteString, Maybe (CommandResult Hash)) ->
                  HashMap RequestKey (Command ByteString, Maybe (CommandResult Hash))
updateInMemKey (k,v) m = HashMap.adjust (\(cmd, _) -> (cmd, Just v)) k m

pairResultWithCmd :: HashMap RequestKey (Command ByteString) ->
                     (RequestKey, (CommandResult Hash)) ->
                     (Command ByteString, CommandResult Hash)
pairResultWithCmd m (rk, cmdr) = case HashMap.lookup rk m of
  Nothing -> error $ "Fatal error: the results for a RequestKey came in, but we can't find the original command\n" ++ show rk ++ "\n#----#\n" ++ show m
  Just cmd -> (cmd, cmdr)

alertListeners :: HashMap RequestKey (CommandResult Hash) -> HistoryService ()
alertListeners m = do
  listeners <- use registeredListeners
  triggered <- return $! HashMap.filterWithKey (\k _ -> HashMap.member k m) listeners
  unless (HashMap.null triggered) $ do
    res <- mapM (alertListener m) $ HashMap.toList triggered
    registeredListeners %= HashMap.filterWithKey (\k _ -> not $ HashMap.member k triggered)
    -- use registeredListeners >>= debug . ("Active Listeners: " ++) . show . HashMap.keysSet
    debug $ "Serviced " ++ show (sum res) ++ " listener(s)"

alertListener :: HashMap RequestKey (CommandResult Hash) -> (RequestKey, [MVar ListenerResult]) -> HistoryService Int
alertListener res (k,mvs) = do
  commandRes <- return $! res HashMap.! k
  -- debug $ "Servicing Listener for: " ++ show k
  fails <- filter not <$> liftIO (mapM (`tryPutMVar` ListenerResult commandRes) mvs)
  unless (null fails) $ debug $ "Registered listener failure for " ++ show k ++ " (" ++ show (length fails) ++ " of " ++ show (length mvs) ++ " failed)"
  return $ length mvs

queryForResults :: (HashSet RequestKey, MVar PossiblyIncompleteResults) -> HistoryService ()
queryForResults (srks, mRes) = do
  pers <- use persistence
  case pers of
    InMemory m -> do
      found <- return $! HashMap.filterWithKey (checkForIndividualResultInMem srks) m
      liftIO $! putMVar mRes $ PossiblyIncompleteResults $ fmap (fromJust.snd) found
      debug $ "Querying for " ++ show (HashSet.size srks) ++ " keys, found " ++ show (HashMap.size found)
    OnDisk{..} -> do
      completed <- return $! HashSet.filter (\k -> not $ HashMap.member k incompleteRequestKeys) srks
      if HashSet.null completed
      then do
        liftIO $! putMVar mRes $ PossiblyIncompleteResults HashMap.empty
      else do
        found <- liftIO $ DB.selectCompletedCommands dbConn completed
        liftIO $! putMVar mRes $ PossiblyIncompleteResults found
        debug $ "Querying for " ++ show (HashSet.size srks) ++ " keys, found " ++ show (HashMap.size found)

-- This is here to try to get GHC to check the fast part first
checkForIndividualResultInMem :: HashSet RequestKey -> RequestKey -> (Command ByteString, Maybe (CommandResult Hash)) -> Bool
checkForIndividualResultInMem _ _ (_,Nothing) = False
checkForIndividualResultInMem s k (_,Just _) = HashSet.member k s

registerNewListeners :: HashMap RequestKey (MVar ListenerResult) -> HistoryService ()
registerNewListeners newListeners' = do
  srks <- return $! HashSet.fromMap $ void newListeners'
  pers <- use persistence
  found <- case pers of
    InMemory m -> do
      return $! fromJust.snd <$> HashMap.filterWithKey (checkForIndividualResultInMem srks) m
    OnDisk{..} -> do
      liftIO $! DB.selectCompletedCommands dbConn srks
  noNeedToListen <- return $! HashSet.intersection (HashSet.fromMap $ void found) srks
  readyToServiceListeners <- return $! HashMap.filterWithKey (\k _ -> HashSet.member k noNeedToListen) newListeners'
  realListeners <- return $! HashMap.filterWithKey (\k _ -> not $ HashSet.member k noNeedToListen) newListeners'
  unless (HashMap.null readyToServiceListeners) $ do
    mapM_ (\(k,v) -> alertListener found (k,[v])) $ HashMap.toList readyToServiceListeners
    debug $ "Immediately serviced " ++ show (HashSet.size noNeedToListen) ++ " listeners"
  unless (HashMap.null realListeners) $ do
    registeredListeners %= HashMap.unionWith (<>) ((:[]) <$> realListeners)
    debug $ "Registered " ++ show (HashMap.size realListeners) ++ " listeners"

_gcVolLogListeners :: HashSet RequestKey -> HistoryService ()
_gcVolLogListeners srks = do
  toGc <- HashMap.filterWithKey (\k _ -> HashSet.member k srks) <$> use registeredListeners
  mapM_ (_gcListener "Transaction was GCed! This generally occurs because disk I/O is failing") $ HashMap.toList toGc
  registeredListeners %= HashMap.filterWithKey (\k _ -> not $ HashSet.member k srks)

_gcListener :: String -> (RequestKey, [MVar ListenerResult]) -> HistoryService ()
_gcListener res (k,mvs) = do
  fails <- filter not <$> liftIO (mapM (`tryPutMVar` GCed res) mvs)
  unless (null fails) $ debug $ "Registered listener failure during GC for " ++ show k ++ " (" ++ show (length fails) ++ " of " ++ show (length mvs) ++ " failed)"


_testHistoryDB :: IO ()
_testHistoryDB = do
  (inC,histC) <- initChans
  replayFromDisk' <- ReplayFromDisk <$> newEmptyMVar
  let fp = Just "/tmp"
      dbg = putStrLn
      env = initHistoryEnv histC inC fp dbg replayFromDisk'
  pers <- setupPersistence dbg fp replayFromDisk'
  let hstate = HistoryState { _registeredListeners = HashMap.empty, _persistence = pers }
  void $ runRWST _go env hstate

_go :: HistoryService ()
_go = do
  addNewKeys [Command "" [] initialHash]
  let rq = RequestKey pactInitialHash
      res = PactResult $ Left $ PactError TxFailure def def . viaShow $ ("some error message" :: String)
  updateExistingKeys (HashMap.fromList [(rq, CommandResult rq Nothing res (Gas 0) Nothing Nothing Nothing [])])
  mv <- liftIO $ newEmptyMVar
  queryForResults (HashSet.singleton rq, mv)
  v <- liftIO $ takeMVar mv
  liftIO $ print v
