Transactional

TransactionalApp.hs

module TransactionalApp where

import Control.Monad.Writer
import Control.Monad.State

{- Model layer -}

data Account = Savings | Normal

deriving instance Eq Account

newtype Balance = Balance { unpackBalance :: Int }

deriving instance Show Balance

-- | Some trivial business logic
balanceAtLeast :: Balance -> Int -> Bool
balanceAtLeast (Balance balance) amount = amount <= balance

{- Application layer -}

newtype App m a = App (WriterT TransactionOutcome m a)

rollback :: Monad m => Reason -> App m ()
rollback reason = App (tell (Rollback reason))

data TransactionOutcome = Commit | Rollback Reason
type Reason = String

instance Semigroup TransactionOutcome where
  Commit <> Commit = Commit
  Rollback r1 <> Rollback r2 = Rollback r1 -- Keep the first reason
  _ <> Rollback r = Rollback r
  Rollback r <> _ = Rollback r

instance Monoid TransactionOutcome where
  mempty = Commit

-- Technicalities
deriving instance Functor m => Functor (App m)
deriving instance Applicative m => Applicative (App m)
deriving instance Monad m => Monad (App m)
deriving instance MonadTrans App -- For 'lift' used below. Nicer: AccountStore instance for App m. 

-- | Data access interface, no transaction control operations!
class AccountStore m where
  withdraw :: Account -> Int -> m Balance
  deposit :: Account -> Int -> m Balance

data WithdrawResult = InsufficientBalance | Withdrawn Int

-- | Application Layer-level helper for withdrawing
withdrawFromSavings :: (Monad m, AccountStore m) => Int -> App m WithdrawResult
withdrawFromSavings amount = do
  remainingBalance <- lift (withdraw Savings amount) -- (W)
  -- Apply model logic
  if remainingBalance `balanceAtLeast` 100 then pure (Withdrawn (amount + 0)) -- amount + 1 will cause rollback in 'transfer'
  else do
    -- Roll back changes at (W)
    rollback "Savings balance must be at least 100"
    pure InsufficientBalance

-- | Application Layer-level helper for depositing
depositNormal :: (Monad m, AccountStore m) => Int -> App m ()
depositNormal amount = void (lift (deposit Normal amount))

-- | The actual use-case, composed of the two helpers
transfer :: (Monad m, AccountStore m) => Int -> App m ()
transfer amount = do
  withdrawResult <- withdrawFromSavings amount
  case withdrawResult of
    InsufficientBalance -> pure () -- Do nothing
    Withdrawn amount' -> do
      depositNormal amount' -- (D)
      -- But let's be paranoidal, see remark in 'withdrawFromSavings'
      unless (amount == amount') (rollback "Unexpected amount withdrawn") -- Rolls back (D) _and_ any other changes

{- Data access layer (stub) -}

-- The in-memory "database"
data Bank = Bank { savings :: Balance, normal :: Balance }

deriving instance Show Bank

-- The stub itself. Tracks account changes in memory, in the state monad.
instance AccountStore (State Bank) where
  withdraw account amount = do
      bank0 <- get
      let
        balance Savings = savings
        balance Normal = normal
        adjust n Savings bank = bank { savings = n }
        adjust n Normal bank = bank { normal = n}
        newBalance = Balance (unpackBalance (balance account bank0) - amount)
      put (adjust newBalance account bank0)
      pure newBalance
  deposit account amount = withdraw account (-amount)

-- | Given current state of the "database" ('Bank'), run the Application Layer use-case using the Data Layer (stub)
-- implementation.
runApplication :: Show a => Bank -> App (State Bank) a -> IO a
runApplication bank (App app) = do
  print bank
  putStrLn "->"
  let ((a, transactionOutcome), bank1) = runState (runWriterT app) bank
  case transactionOutcome of
    Rollback reason -> putStrLn ("Roll back changes, reason: " <> reason) -- Simulates keeping the original 'bank'
    Commit -> print bank1 -- Simulates keeping (commiting) changes
  pure a

demo :: IO ()
demo = runApplication (Bank {savings = Balance 200, normal = Balance 10 }) (transfer 100) -- 101 will roll back