Exceptions

Simple example

{-# LANGUAGE DeriveDataTypeable #-}

import Prelude hiding (catch)
import Control.Exception
import Data.Typeable

data MyError = MyError String deriving (Show, Typeable)
instance Exception MyError

catcher :: IO a -> IO (Maybe a)
catcher action = fmap Just action `catch` handler
    where handler (MyError msg) = do putStrLn msg; return Nothing
*Main> catcher $ readFile "/dev/null"
Just ""
*Main> catcher $ throwIO $ MyError "something bad"
something bad
Nothing

Exceptions in pure code

Exceptions and laziness

Exceptions and laziness

Exceptions and laziness

Exceptions and laziness continued

Solution

seqList :: [a] -> b -> b
seqList [] b     = b
seqList (a:as) b = seq a $ seqList as b

A few more exception functions

Monadic exceptions

Haskell threads

Example: timeout

data TimedOut = TimedOut UTCTime deriving (Eq, Show, Typeable)
instance Exception TimedOut

timeout :: Int -> IO a -> IO (Maybe a)
timeout usec action = do
  -- Create unique exception val (for nested timeouts):
  expired <- fmap TimedOut getCurrentTime

  ptid <- myThreadId
  let child = do threadDelay usec
                 throwTo ptid expired
      parent = do ctid <- forkIO child
                  result <- action
                  killThread ctid
                  return $ Just result
  catchJust (\e -> if e == expired then Just e else Nothing) 
            parent
            (\_ -> return Nothing)

MVars

Example: pingpong benchmark

import Control.Concurrent
import Control.Exception
import Control.Monad

pingpong :: Bool -> Int -> IO ()
pingpong v n = do
  mvc <- newEmptyMVar   -- MVar read by child
  mvp <- newEmptyMVar   -- MVar read by parent
  let parent n | n > 0 = do when v $ putStr $ " " ++ show n
                            putMVar mvc n
                            takeMVar mvp >>= parent
               | otherwise = return ()
      child = do n <- takeMVar mvc
                 putMVar mvp (n - 1)
                 child
  tid <- forkIO child
  parent n `finally` killThread tid
  when v $ putStrLn ""
*Main> pingpong True 10
 10 9 8 7 6 5 4 3 2 1

Sidenote: benchmarking

import Criterion.Main

...

main :: IO ()
main = defaultMain [
        bench "thread switch test" mybench
       ]
    where mybench = pingpong False 10000
$ ghc -O pingpong.hs 
[1 of 1] Compiling Main             ( pingpong.hs, pingpong.o )
Linking pingpong ...
$ ./pingpong 
...
benchmarking thread switch test
mean: 3.774590 ms, lb 3.739223 ms, ub 3.808865 ms, ci 0.950
...

OS threads

$ rm pingpong
$ ghc -threaded -O pingpong.hs 
Linking pingpong ...
$ ./pingpong
...
mean: 121.1729 ms, lb 120.5601 ms, ub 121.7044 ms, ci 0.950
...

Bound vs. unbound threads

What good are OS threads?

Asynchronous exceptions

Asynchronous exceptions

Masking exceptions

Masking exceptions (continued)

wrap :: IO a -> IO a          -- Fixed version of wrap
wrap action = do
  mv <- newEmptyMVar
  mask $ \unmask -> do
      tid <- forkIO $ (unmask action >>= putMVar mv) `catch`
                      \e@(SomeException _) -> putMVar mv (throw e)
      let loop = takeMVar mv `catch` \e@(SomeException _) ->
                 throwTo tid e >> loop
      loop

The bracket function

Working with MVars

Alternate Mutex

Condition variables

data Cond = Cond (MVar [MVar ()])

cond_create :: IO Cond
cond_create = liftM Cond $ newMVar []
-- liftM is fmap for Monads (i.e., no required Functor instance):
-- liftM f m1 = do x <- m1; return (f m1)

cond_wait :: Mutex -> Cond -> IO ()
cond_wait m (Cond waiters) = do
  me <- newEmptyMVar
  modifyMVar_ waiters $ \others -> return $ others ++ [me]
  mutex_unlock m   -- note we don't care if preempted after this
  takeMVar me `finally` mutex_lock m
  
cond_signal, cond_broadcast :: Cond -> IO ()
cond_signal (Cond waiters) = modifyMVar_ waiters wakeone
    where wakeone [] = return []
          wakeone (w:ws) = putMVar w () >> return ws

cond_broadcast (Cond waiters) = modifyMVar_ waiters wakeall
    where wakeall ws = do mapM_ (flip putMVar ()) ws
                          return []

Channels

Channel implementation [simplified]

data Item a = Item a (Stream a)
type Stream a = MVar (Item a)
data Chan a = Chan (MVar (Stream a)) (MVar (Stream a))

newChan :: IO (Chan a)
newChan = do
  empty <- newEmptyMVar
  liftM2 Chan (newMVar empty) (newMVar empty)
-- liftM2 is like liftM for functions of two arguments:
-- liftM2 f m1 m2 = do x1 <- m1; x2 <- m2; return (f x1 x2)

writeChan :: Chan a -> a -> IO ()
writeChan (Chan _ w) a = do
  empty <- newEmptyMVar
  modifyMVar_ w $ \oldEmpty -> do
    putMVar oldEmpty (Item a empty)
    return empty

readChan :: Chan a -> IO a
readChan (Chan r _) =
    modifyMVar r $ \full -> do
      (Item a newFull) <- takeMVar full
      return (newFull, a)

Networking

Solution

withClient :: PortID -> (Handle -> IO a) -> IO a
withClient listenPort fn =
  bracket (listenOn listenPort) sClose $ \s -> do
    bracket (accept s) (\(h, _, _) -> hClose h) $
      \(h, host, port) -> do
        putStrLn $ "Connection from host " ++ host
                   ++ " port " ++ show port
        fn h

Exercise

Solution

play :: MVar Move -> MVar Move
     -> (Handle, HostName, PortNumber) -> IO ()
play myMoveMVar opponentMoveMVar (h, host, port) = do
  putStrLn $ "Connection from host " ++ host ++ " port " ++ show port
  myMove <- getMove h
  putMVar myMoveMVar myMove
  opponentMove <- takeMVar opponentMoveMVar
  let o = outcome myMove opponentMove
  hPutStrLn h $ "You " ++ show o

netrock :: PortID -> IO ()
netrock listenPort =
  bracket (listenOn listenPort) sClose $ \s -> do
    mv1 <- newEmptyMVar
    mv2 <- newEmptyMVar
    let cleanup mv (h,_,_) = do
          tryPutMVar mv (error "something blew up")
          hClose h
    wait <- newEmptyMVar
    forkIO $ bracket (accept s) (cleanup mv1) (play mv1 mv2)
      `finally` putMVar wait ()
    bracket (accept s) (cleanup mv2) (play mv2 mv1)
    takeMVar wait

Networking

Example: netcat

netcat :: String -> String -> IO ()
netcat host port = do
  -- Extract address from first AddrInfo in list
  AddrInfo{ addrAddress = addr, addrFamily = family }:_
      <- getAddrInfo Nothing (Just host) (Just port)

  -- Create a TCP socket connected to server
  s <- socket family Stream 0
  connect s addr

  -- Convert socket to handle
  h <- socketToHandle s ReadWriteMode
  hSetBuffering h NoBuffering  -- THIS IS IMPORTANT

  -- Punt on complex locale stuff
  hSetBinaryMode stdout True

  -- Copy data back and forth taking advantage of laziness
  done <- newEmptyMVar
  forkIO $ (hGetContents h >>= putStr) `finally` putMVar done ()
  getContents >>= hPutStr h
  takeMVar done