{-# 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
     }