Basic concurrency samples with Haskell

AtomicBank.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.12 script

import Control.Concurrent.STM

transfer :: TVar Int -> TVar Int -> Int -> STM (Either String (Int, Int))
transfer from to amount = do
  balanceA <- readTVar from
  balanceB <- readTVar to

  if (balanceA - amount) >= 0
  then do
    writeTVar from (balanceA - amount)
    writeTVar to (balanceB + amount)
    pure $ Right ((balanceA - amount), (balanceB + amount))
  else do
    pure $ Left "Not enought balance"

main :: IO ()
main = do
  let tranferAmount = 40

  accA <- newTVarIO 50
  accB <- newTVarIO 50

  result <- atomically $ transfer accA accB tranferAmount

  case result of
    Right (balA, balB) -> putStrLn $
      "Tranfered "
      ++ (show tranferAmount)
      ++ " from a to b. Final balance: a("
      ++ (show balA)
      ++ "), b ("
      ++ (show balB)
      ++ ")"
    Left err -> putStrLn err

BankRupt.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.12 script

import Control.Concurrent.MVar

deposit :: MVar Int -> Int -> IO ()
deposit acc amount = putMVar acc amount

transfer :: MVar Int -> MVar Int -> Int -> IO (Either String (Int, Int))
transfer from to amount = do
  balanceA <- takeMVar from
  balanceB <- takeMVar to

  let finalBalanceA = balanceA - amount
  let finalBalanceB = balanceB + amount

  if finalBalanceA >= 0
  then do
    putMVar from finalBalanceA
    putMVar to finalBalanceB
    pure $ Right (finalBalanceA, finalBalanceB)
  else do
    putMVar from balanceA
    putMVar to balanceB
    pure $ Left "Not enough money!"

main :: IO ()
main = do
  let tranferAmount = 50

  accA <- newEmptyMVar
  accB <- newEmptyMVar

  deposit accA 100
  deposit accB 10

  result <- transfer accA accB tranferAmount

  case result of
    Right (balA, balB) -> putStrLn $
      "Tranfered "
      ++ (show tranferAmount)
      ++ " from a to b. Final balance: a("
      ++ (show balA)
      ++ "), b ("
      ++ (show balB)
      ++ ")"
    Left err -> putStrLn err

Concurrency.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.12 script

import Control.Concurrent
import Control.Concurrent.Async

readFile' :: String ->  IO String
readFile' filePath = do
  content <- readFile filePath
  pure content

readFileToMVar' :: MVar String -> String ->  IO ()
readFileToMVar' mvar filePath = do
  content <- readFile filePath
  putMVar mvar content

main :: IO ()
main = do
  runItVanilla
  runItWithASync
  runItWithMVar
  runItWithConcurrently

runItVanilla :: IO ()
runItVanilla = do
  threadId <- forkIO $ do
    content <- readFile' "fileA"
    putStrLn content
  putStrLn "Done it vanilla!"

runItWithMVar :: IO ()
runItWithMVar = do
  mvar <- newEmptyMVar
  threadId <- forkIO $ readFileToMVar' mvar "fileA"
  contents <- takeMVar mvar
  putStrLn contents
  putStrLn "Done with MVar!"

runItWithASync :: IO ()
runItWithASync = do
  myAsync <- async $ readFile' "fileA"
  result <- waitCatch myAsync
  case result of
    Right content -> putStrLn content
    Left err -> putStrLn "There was an error reading a file"
  cancel myAsync
  putStrLn "Done with Async!"

runItWithConcurrently :: IO ()
runItWithConcurrently = do
  (resultA, resultB) <- concurrently (readFile' "fileA") (readFile' "fileB")
  putStrLn $ resultA ++ resultB
  putStrLn "Done with concurrently!"

fileA

Hello

fileB

World!

RunServerClientWithAsync.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.12 script

{-# LANGUAGE OverloadedStrings #-}

import Network.Wai
import Network.HTTP.Types
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Simple
import qualified Data.ByteString.Char8 as B8
import Control.Concurrent.Async

app :: Application
app _ respond = do
    putStrLn "I've done some IO here"
    respond
      (responseLBS
        status200
        [("Content-Type", "text/plain")]
        "Hello, Web!")


client :: IO ()
client = do
  response <- httpBS "http://localhost:8080/"
  B8.putStrLn (getResponseBody response)

main :: IO ()
main = do
    putStrLn "http://localhost:8080/"
    withAsync (run 8080 app) $ \_ -> do client