{-# LANGUAGE TemplateHaskell #-}

module Temporal.Workflow.Internal.Instance (
  InstanceM,
  runInstanceM,
  WorkflowInstance (..),
  Info (..),
  Sequences (..),
  Sequence (..),
  Reversed,
  fromReversed,
  push,
  flushCommands,
  nextExternalCancelSequence,
  nextChildWorkflowSequence,
  nextExternalSignalSequence,
  nextTimerSequence,
  nextActivitySequence,
  nextConditionSequence,
) where

import Control.Monad.Logger
import Control.Monad.Reader
import Data.ProtoLens
import qualified Data.Text as T
import GHC.Stack
import Lens.Family2
import qualified Proto.Temporal.Sdk.Core.WorkflowCompletion.WorkflowCompletion as Core
import qualified Proto.Temporal.Sdk.Core.WorkflowCompletion.WorkflowCompletion_Fields as Completion
import Temporal.Common
import Temporal.Workflow.Internal.Monad
import Temporal.Workflow.Types
import UnliftIO


runInstanceM :: WorkflowInstance -> InstanceM a -> IO a
runInstanceM :: forall a. WorkflowInstance -> InstanceM a -> IO a
runInstanceM WorkflowInstance
worker InstanceM a
m = ReaderT WorkflowInstance IO a -> WorkflowInstance -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (InstanceM a -> ReaderT WorkflowInstance IO a
forall a. InstanceM a -> ReaderT WorkflowInstance IO a
unInstanceM InstanceM a
m) WorkflowInstance
worker


flushCommands :: HasCallStack => InstanceM ()
flushCommands :: HasCallStack => InstanceM ()
flushCommands = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  info <- readIORef inst.workflowInstanceInfo
  cmds <- atomically $ do
    currentCmds <- readTVar inst.workflowCommands
    writeTVar inst.workflowCommands $ Reversed []
    pure currentCmds
  let completionSuccessful :: Core.Success
      completionSuccessful = Success
forall msg. Message msg => msg
defMessage Success -> (Success -> Success) -> Success
forall s t. s -> (s -> t) -> t
& LensLike' f Success [WorkflowCommand]
forall {f :: * -> *}.
Identical f =>
LensLike' f Success [WorkflowCommand]
forall (f :: * -> *) s a.
(Functor f, HasField s "commands" a) =>
LensLike' f s a
Completion.commands (forall {f :: * -> *}.
 Identical f =>
 LensLike' f Success [WorkflowCommand])
-> [WorkflowCommand] -> Success -> Success
forall s t a b. Setter s t a b -> b -> s -> t
.~ Reversed WorkflowCommand -> [WorkflowCommand]
forall a. Reversed a -> [a]
fromReversed Reversed WorkflowCommand
cmds
      completionMessage :: Core.WorkflowActivationCompletion
      completionMessage =
        WorkflowActivationCompletion
forall msg. Message msg => msg
defMessage
          WorkflowActivationCompletion
-> (WorkflowActivationCompletion -> WorkflowActivationCompletion)
-> WorkflowActivationCompletion
forall s t. s -> (s -> t) -> t
& LensLike' f WorkflowActivationCompletion Text
forall {f :: * -> *}.
Identical f =>
LensLike' f WorkflowActivationCompletion Text
forall (f :: * -> *) s a.
(Functor f, HasField s "runId" a) =>
LensLike' f s a
Completion.runId (forall {f :: * -> *}.
 Identical f =>
 LensLike' f WorkflowActivationCompletion Text)
-> Text
-> WorkflowActivationCompletion
-> WorkflowActivationCompletion
forall s t a b. Setter s t a b -> b -> s -> t
.~ RunId -> Text
rawRunId Info
info.runId
          WorkflowActivationCompletion
-> (WorkflowActivationCompletion -> WorkflowActivationCompletion)
-> WorkflowActivationCompletion
forall s t. s -> (s -> t) -> t
& LensLike' f WorkflowActivationCompletion Success
forall {f :: * -> *}.
Identical f =>
LensLike' f WorkflowActivationCompletion Success
forall (f :: * -> *) s a.
(Functor f, HasField s "successful" a) =>
LensLike' f s a
Completion.successful (forall {f :: * -> *}.
 Identical f =>
 LensLike' f WorkflowActivationCompletion Success)
-> Success
-> WorkflowActivationCompletion
-> WorkflowActivationCompletion
forall s t a b. Setter s t a b -> b -> s -> t
.~ Success
completionSuccessful
  $(logDebug) ("flushCommands: " <> T.pack (show completionMessage) <> " " <> T.pack (prettyCallStack callStack))
  res <- liftIO $ inst.workflowCompleteActivation completionMessage
  case res of
    Left WorkerError
err -> do
      $(logError) (Text
"flushCommands: failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (WorkerError -> String
forall a. Show a => a -> String
show WorkerError
err))
      WorkerError -> InstanceM ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO WorkerError
err
    Right () -> () -> InstanceM ()
forall a. a -> InstanceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


nextExternalCancelSequence :: InstanceM Sequence
nextExternalCancelSequence :: InstanceM Sequence
nextExternalCancelSequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
externalCancel Sequences
seqs
    in (Sequences
seqs {externalCancel = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')


nextChildWorkflowSequence :: InstanceM Sequence
nextChildWorkflowSequence :: InstanceM Sequence
nextChildWorkflowSequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
childWorkflow Sequences
seqs
    in (Sequences
seqs {childWorkflow = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')


nextExternalSignalSequence :: InstanceM Sequence
nextExternalSignalSequence :: InstanceM Sequence
nextExternalSignalSequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
externalSignal Sequences
seqs
    in (Sequences
seqs {externalSignal = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')


nextTimerSequence :: InstanceM Sequence
nextTimerSequence :: InstanceM Sequence
nextTimerSequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
timer Sequences
seqs
    in (Sequences
seqs {timer = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')


nextActivitySequence :: InstanceM Sequence
nextActivitySequence :: InstanceM Sequence
nextActivitySequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
activity Sequences
seqs
    in (Sequences
seqs {activity = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')


nextConditionSequence :: InstanceM Sequence
nextConditionSequence :: InstanceM Sequence
nextConditionSequence = do
  inst <- InstanceM WorkflowInstance
forall r (m :: * -> *). MonadReader r m => m r
ask
  atomicModifyIORef' inst.workflowSequences $ \Sequences
seqs ->
    let seq' :: Word32
seq' = Sequences -> Word32
condition Sequences
seqs
    in (Sequences
seqs {condition = succ seq'}, Word32 -> Sequence
Sequence Word32
seq')