gistfile1.txt

--
-- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the 3-clause BSD licence.
--

module Main where
import Network -- network
import qualified Data.ByteString.Char8 as S -- bytestring
import Control.Concurrent
import Data.Serialize -- cereal
import System.IO
import Control.Monad
import Control.Applicative
import Data.Word

-- client a conects
-- client b connects
-- server sends Response (ready)
-- client a sends Request
-- client b sends Request
-- server sends Response (ready)

data Request = Betray | Cooperate
  deriving Show

data Response = Betrayed | Cooperated
  deriving Show

instance Serialize Request where
    put Betray = put (1 :: Word8)
    put Cooperate = put (2 :: Word8)
    get = do
        byte <- get :: Get Word8
        case byte of
            1 -> return Betray
            2 -> return Cooperate
            _ -> fail "Invalid Request"

instance Serialize Response where
    put Betrayed = put (4 :: Word8)
    put Cooperated = put (5 :: Word8)
    get = do
        byte <- get :: Get Word8
        case byte of
            4 -> return Betrayed
            5 -> return Cooperated
            _ -> fail "Invalid Response"

main :: IO ()
main = do
    sock <- listenOn (PortNumber 1234)

    forever $ do
        client_pair <- connectPair sock
        forkIO (runGame client_pair (0,0) 16)

runGame :: (Handle, Handle) -> (Int, Int) -> Int -> IO ()
runGame (h1, h2) (years1, years2) 0 = do
    putStrLn $ "First player: " ++ show years1
    putStrLn $ "Second player: " ++ show years2
    hClose h1
    hClose h2
runGame hs@(h1, h2) (years1, years2) rounds = do
    (req1, req2) <- runBoth (S.hGetLine >=> tryDecode)
    case req1 of
        Cooperate -> do
            S.hPutStrLn h2 (encode Cooperated)
            case req2 of
                Cooperate -> do
                    S.hPutStrLn h1 (encode Cooperated)
                    runGame hs (succ years1, succ years2) (pred rounds)
                Betray -> do
                    S.hPutStrLn h1 (encode Betrayed)
                    runGame hs ((years1 + 3), years2) (pred rounds)
        Betray -> do
            S.hPutStrLn h2 (encode Betrayed)
            case req2 of
                Cooperate -> do
                    S.hPutStrLn h1 (encode Cooperated)
                    runGame hs (years1, years2 + 3) (pred rounds)
                Betray -> do
                    S.hPutStrLn h1 (encode Betrayed)
                    runGame hs ((years1 + 2), (years2 + 2)) (pred rounds)
  where
    tryDecode bs =
        case decode bs of
            Left e -> runBoth hClose >> error e
            Right response -> return response

    runBoth f = (,) <$> f h1 <*> f h2
    runBoth_ = void . runBoth

    writeBoth = runBoth_ . flip S.hPutStrLn

connectPair :: Socket -> IO (Handle, Handle)
connectPair sock = (,) <$> acceptHandle <*>  acceptHandle
  where
    acceptHandle = do
        (h, _, _) <- accept sock
        return h