actor-0.1: MarketPlace.hs
{-# LANGUAGE MultiParamTypeClasses, PatternSignatures, TypeSynonymInstances, FlexibleInstances #-}
-- a market-place using server and client actors
import Network.Socket hiding (send)
import System.IO
import Control.Exception
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Monad
import Control.Monad.Fix (fix)
import Actor.ActorBase
import Actor.ActorSyntax
import Actor.ActorCompiler
import Actor.ActorLinearSearch
-- types of messages
data MsgClient = Arrived (L String)
-- notifies about newly arrived clients
| DisConnected (L String)
-- disconnected clients
| Sold (L String)
| Bought (L String)
-- notifies about sold/bought items
valHash_MsgClient = HashOp { numberOfTables = 4,
hashMsg = \ msg -> case msg of
Arrived _ -> 1
DisConnected _ -> 2
Sold _ -> 3
Bought _ -> 4 }
data MsgServer =
New (L (PID MsgClient)) (L String)
-- informs server about new clients
| Sell (L (PID MsgClient)) (L String)
-- sell request
| Buy (L (PID MsgClient)) (L String)
-- buy request
| Done (L (PID MsgClient)) (L String)
-- tell server I'm done
valHash_MsgServer = HashOp { numberOfTables = 4,
hashMsg = \ msg -> case msg of
New _ _ -> 1
Sell _ _ -> 2
Buy _ _ -> 3
Done _ _ -> 4 }
instance Eq MsgClient where
(==) (Arrived x) (Arrived y) = x == y
(==) (DisConnected x) (DisConnected y) = x == y
(==) (Sold x) (Sold y) = x == y
(==) (Bought x) (Bought y) = x == y
(==) _ _ = False
instance Eq MsgServer where
(==) (New _ x) (New _ y) = x == y
(==) (Sell _ x) (Sell _ y) = x == y
(==) (Buy _ x) (Buy _ y) = x == y
(==) (Done _ x) (Done _ y) = x == y
(==) _ _ = False
-- boiler plate
instance Show MsgClient where
show (Arrived (Val x)) = "Arrived " ++ show x
show (DisConnected (Val x)) = "Disconnected " ++ show x
show (Sold (Val x)) = "Sold " ++ show x
show (Bought (Val x)) = "Bought " ++ show x
instance Show MsgServer where
show (New _ (Val x)) = "New " ++ show x
show (Sell _ (Val x)) = "Sell " ++ show x
show (Buy _ (Val x)) = "Buy " ++ show x
show (Done _ (Val x)) = "Done " ++ show x
show _ = "vars are not showable"
instance EMatch MsgClient where
match tags (Arrived x) (Arrived y) = match tags x y
match tags (DisConnected x) (DisConnected y) = match tags x y
match tags (Sold x) (Sold y) = match tags x y
match tags (Bought x) (Bought y) = match tags x y
match tags _ _ = return (False, tags)
instance EMatch MsgServer where
match tags (New x1 x2) (New y1 y2) =
do { (b1,t1) <- match tags x1 y1
; (b2,t2) <- match t1 x2 y2
; return (b1 && b2, t2) }
match tags (Sell x1 x2) (Sell y1 y2) =
do { (b1,t1) <- match tags x1 y1
; (b2,t2) <- match t1 x2 y2
; return (b1 && b2, t2) }
match tags (Buy x1 x2) (Buy y1 y2) =
do { (b1,t1) <- match tags x1 y1
; (b2,t2) <- match t1 x2 y2
; return (b1 && b2, t2) }
match tags (Done x1 x2) (Done y1 y2) =
do { (b1,t1) <- match tags x1 y1
; (b2,t2) <- match t1 x2 y2
; return (b1 && b2, t2) }
match tags _ _ = return (False, tags)
-- we're only allowed to match a pid
-- but we can't compare two pids
instance EMatch (PID msg) where
match tags _ _ = return (False, tags)
instance Eq (Chan msg) where
(==) = error "impossible: == among channels"
instance Show (Chan msg) where
show = error "impossible: show for channels"
instance Show (MVar ThreadId) where
show = error "impossible: show for thread id"
-- EMatch depends on Eq and Show
instance Eq (Act msg) where
(==) _ _ = False
instance Show (Act msg) where
show _ = "Actor"
instance EMatch String where
match tags x y = return (x==y,tags)
-- client interface
class ArrivedMsg a where
arrivedMsg :: a -> MsgClient
instance ArrivedMsg (VAR String) where
arrivedMsg x = Arrived (Var x)
instance ArrivedMsg String where
arrivedMsg s = Arrived (Val s)
class DisConnectedMsg a where
disconnectedMsg :: a -> MsgClient
instance DisConnectedMsg (VAR String) where
disconnectedMsg (x@(VAR{})) = DisConnected (Var x)
instance DisConnectedMsg String where
disconnectedMsg s = DisConnected (Val s)
class SoldMsg a where
soldMsg :: a -> MsgClient
instance SoldMsg (VAR String) where
soldMsg x = Sold (Var x)
instance SoldMsg String where
soldMsg x = Sold (Val x)
class BoughtMsg a where
boughtMsg :: a -> MsgClient
instance BoughtMsg (VAR String) where
boughtMsg x = Bought (Var x)
instance BoughtMsg String where
boughtMsg x = Bought (Val x)
-- server interface
class NewMsg a b where
newMsg :: a -> b -> MsgServer
instance NewMsg (VAR (PID MsgClient)) (VAR String) where
newMsg x y = New (Var x) (Var y)
instance NewMsg (VAR (PID MsgClient)) String where
newMsg x y = New (Var x) (Val y)
instance NewMsg (PID MsgClient) (VAR String) where
newMsg x y = New (Val x) (Var y)
instance NewMsg (PID MsgClient) String where
newMsg x y = New (Val x) (Val y)
class SellMsg a b where
sellMsg :: a -> b -> MsgServer
instance SellMsg (VAR (PID MsgClient)) (VAR String) where
sellMsg x y = Sell (Var x) (Var y)
instance SellMsg (VAR (PID MsgClient)) String where
sellMsg x y = Sell (Var x) (Val y)
instance SellMsg (PID MsgClient) (VAR String) where
sellMsg x y = Sell (Val x) (Var y)
instance SellMsg (PID MsgClient) String where
sellMsg x y = Sell (Val x) (Val y)
class BuyMsg a b where
buyMsg :: a -> b -> MsgServer
instance BuyMsg (VAR (PID MsgClient)) (VAR String) where
buyMsg x y = Buy (Var x) (Var y)
instance BuyMsg (VAR (PID MsgClient)) String where
buyMsg x y = Buy (Var x) (Val y)
instance BuyMsg (PID MsgClient) (VAR String) where
buyMsg x y = Buy (Val x) (Var y)
instance BuyMsg (PID MsgClient) String where
buyMsg x y = Buy (Val x) (Val y)
class DoneMsg a b where
doneMsg :: a -> b -> MsgServer
instance DoneMsg (VAR (PID MsgClient)) (VAR String) where
doneMsg x y = Done (Var x) (Var y)
instance DoneMsg (VAR (PID MsgClient)) String where
doneMsg x y = Done (Var x) (Val y)
instance DoneMsg (PID MsgClient) (VAR String) where
doneMsg x y = Done (Val x) (Var y)
instance DoneMsg (PID MsgClient) String where
doneMsg x y = Done (Val x) (Val y)
-- auxilliary
loop c = do { c; loop c}
toPID = actorToPID
-- each new connection creates a new client
eventLoop :: Socket -> Act MsgServer -> IO ()
eventLoop sock serverActor = do
conn <- accept sock
forkIO (spawnClient conn serverActor)
eventLoop sock serverActor
-- client asks for name, registers with server and
-- waits for messages from server
spawnClient (sock,_) serverActor =
do { (client :: Act MsgClient) <- createActor valHash_MsgClient
; hdl <- socketToHandle sock ReadWriteMode
; hSetBuffering hdl NoBuffering
; hPutStrLn hdl "Hi, what's your name?"
; name <- liftM init (hGetLine hdl)
; send (toPID serverActor) (newMsg (toPID client) name)
; hPutStrLn hdl "Anything you'd like to sell/buy ([Sitem]/[Bitem])?"
; cmd <- liftM init (hGetLine hdl)
; case cmd of
('S':item) -> send (toPID serverActor) (sellMsg (toPID client) item)
('B':item) -> send (toPID serverActor) (buyMsg (toPID client) item)
_ -> hPutStrLn hdl "Invalid input"
; x <- newVar :: IO (VAR String)
; y <- newVar :: IO (VAR String)
; let goodbye = do { hPutStrLn hdl ("\n Bye!")
; send (toPID serverActor) (doneMsg (toPID client) name)
; hClose hdl
}
; let go =
receive client
[ [arrivedMsg x] .->.
do { v1 <- readVar x
; hPutStrLn hdl ("\n Arrived: " ++ show v1)
; go
}
, [disconnectedMsg x] .->.
do { v1 <- readVar x
; hPutStrLn hdl ("\n Disconnected: " ++ show v1)
; go
}
, [soldMsg y] .->.
do { v2 <- readVar y
; hPutStrLn hdl ("\n Sold: " ++ show v2)
; goodbye
}
, [boughtMsg y] .->.
do { v2 <- readVar y
; hPutStrLn hdl ("\n Bought: " ++ show v2)
; goodbye
}
]
; go
}
-- server, stores new client and informs others
server self =
do { s <- newVar :: IO (VAR String)
; c <- newVar :: IO (VAR (PID MsgClient))
; c2 <- newVar :: IO (VAR (PID MsgClient))
; let go clients =
receive self
[ [newMsg c s] .->.
do { v1 <- readVar s
; v2 <- readVar c
; putStrLn ("New user " ++ show v1 ++ " has arrived, will inform others");
; mapM (\ other -> send other (arrivedMsg v1)) clients
; go (v2:clients)
}
, [sellMsg c s, buyMsg c2 s] .->.
do { v1 <- readVar s
; putStrLn ("Item " ++ show v1 ++ "sold/bought")
; cv <- readVar c
; cv2 <- readVar c2
; send cv (soldMsg v1)
; send cv2 (boughtMsg v1)
; go clients
}
, [doneMsg c s] .->.
do { v1 <- readVar s
; v2 <- readVar c
; putStrLn ("User " ++ show v1 ++ "is done, will inform others");
; mapM (\ other -> send other (disconnectedMsg v1)) clients
; go clients
-- we should actually delete c from the list of clients
-- there's no easy way at the moment
}
]
; go [] -- initially there are no clients
}
main :: IO ()
main =
do { (srv :: Act MsgServer) <- createActor valHash_MsgServer
; runActor srv server
; sock <- socket AF_INET Stream 0
; setSocketOption sock ReuseAddr 1
; bindSocket sock (SockAddrInet 4242 iNADDR_ANY)
; listen sock 2
; eventLoop sock srv
}