STM-talk

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Concurrent.STM

newtype Money = Money Int deriving (Show, Num, Ord, Eq)

data Account = Account{
  aBalance :: Money,
  aAccountId :: Int
}

withdrawFunds :: TVar Account -> Money -> STM Money
withdrawFunds accountVar amount = do
   account <- readTVar accountVar
   if (aBalance account) > amount
    then writeTVar accountVar account{aBalance = (aBalance account) `subtract` amount} >> return amount
     else retry

withdrawNonSufficientFunds :: TVar Account -> TChan Account -> Money -> STM Money
withdrawNonSufficientFunds accountVar nsfChan amount = do
  account <- readTVar accountVar
  let account' = account{aBalance = (aBalance account) `subtract` amount}
  writeTVar accountVar account'
  writeTChan nsfChan account'
  return amount

withdrawEvil :: TVar Account -> TChan Account -> Money -> STM Money
withdrawEvil accountVar nsfChan amount = do
  withdrawFunds accountVar amount `orElse` withdrawNonSufficientFunds accountVar nsfChan amount 

sendNSFNotification :: TChan Account -> IO ()
sendNSFNotification nsfChan = do
  account <- atomically $ readTChan nsfChan
  print $ "Send NSF Notice to account " ++ (show $ aAccountId account)

main :: IO ()
main = do
  account1 <- newTVarIO $ Account 100 1
  account2 <- newTVarIO $ Account 200 2
  nsfChan <- newTChanIO
  withdraw1 <- atomically $ withdrawEvil account1 nsfChan (Money 50)
  withdraw2 <- atomically $ withdrawEvil account2 nsfChan (Money 500)

  print $ "Account 1 withrew " ++ (show withdraw1)
  print $ "Account 2 withrew " ++ (show withdraw2)
  sendNSFNotification nsfChan