Client Message SEnding

[darcs-mirror-haskell-partty.git] / Partty.hs

diff --git a/Partty.hs b/Partty.hs
index 801410c..ab68a75 100644 (file)
--- a/Partty.hs
+++ b/Partty.hs
@@ -9,7 +9,7 @@ import Control.Monad.Writer
 import Network
 import System.IO
 
 import Network
 import System.IO
 

-type Player = Int
+type Player = String

 type Day = Int
 type Place = Int
 
 type Day = Int
 type Place = Int
 


@@ -34,9 +34,15 @@ data IncomingMessage = InternalMessage InternalMessage
 data DayMessage      = DayStarts
 -- Events that we want to send to the user code and that
 -- can NOT be reacted upon
 data DayMessage      = DayStarts
 -- Events that we want to send to the user code and that
 -- can NOT be reacted upon

-data NightMessage    = NightStarts
+data NightMessage    = Initialize
+                    | NightStarts

 -- Pure bookkeeping events
 data InternalMessage = MyPlayerId Player
 -- Pure bookkeeping events
 data InternalMessage = MyPlayerId Player

+                     | Welcome
+                    | PlayerJoined String
+                    | GameStarting
+                    | MyIdIs Player
+                    | PlayerEnter Player Place

 
 
 {- Einzusortieren:
 
 
 {- Einzusortieren:


@@ -70,7 +76,7 @@ type DayCallback d   = DayMessage -> DayMonad d ()
 type NightCallback d = NightMessage -> NightMonad d ()
 
 data ParttyState = ParttyState
 type NightCallback d = NightMessage -> NightMonad d ()
 
 data ParttyState = ParttyState

-       { psHandle      :: Handle
+       { psMyName      :: Player

        , psDay         :: Day
        , psPlayerInfo  :: Map Player PlayerInformation
        , psPartyHistory:: [(Day,Place)]
        , psDay         :: Day
        , psPlayerInfo  :: Map Player PlayerInformation
        , psPartyHistory:: [(Day,Place)]


@@ -84,18 +90,68 @@ type NightMonad d =                          ReaderT ParttyState (StateT d IO)
 
 -- Start
 
 
 -- Start
 

--- Hostname, Port, Playername, Callback
-runPartty :: String -> Int -> String -> DayCallback d -> NightCallback d -> IO ()
-runPartty = undefined
+-- Hostname, Port, Playername, Password, Callback
+runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
+runPartty host port username password dcb ncb initialData = do 
+       h <- connectTo host (PortNumber (fromIntegral port))
+       InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
+       hPutStrLn h $ unwords ["login", username, password]
+       InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
+       when (myName /= username) $ error "Server returned a different name for me"
+
+       -- login has been successful, wait for the server start event
+       fix $ \loop -> do
+               msg <- parseIncomingMessage `liftM` hGetLine h
+               case msg of 
+                       (InternalMessage GameStarting) -> return ()
+                       otherwise                      -> do
+                               putStrLn "Waiting for game start..."
+                               loop
+       
+       -- We expect two more fixed events. If the server changes, this breaks!
+       
+       InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
+       InternalMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
+       when (player /= myId) $ error "Server did not tell us where we start"
+
+       let initialState = ParttyState
+               { psMyName      = myId
+               , psDay         = 0
+               , psPlayerInfo  = empty
+               , psPartyHistory= []
+               , psPlace       = startPlace
+               , psPlayers     = []
+               }
+
+       -- The rest of the events are handled in the regular loop. Run the initial event
+       -- and call the runner
+       
+       d' <- callNightCallback ncb initialState initialData Initialize
+
+       runner h dcb ncb initialState d'

 
 

+callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
+callDayCallback dcb ps d e = do
+       flip runStateT d $
+               flip runReaderT ps $ do
+                       execWriterT $ do
+                               dcb e
+
+callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
+callNightCallback ncb ps d e = do
+       flip execStateT d $
+               flip runReaderT ps $ do
+                       ncb e
+                               

 
 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
 runner h dcb ncb = fix $ \loop ps d -> do
        (e,ps') <- getNextUserMessage h ps
 
 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
 runner h dcb ncb = fix $ \loop ps d -> do
        (e,ps') <- getNextUserMessage h ps

-       (client_messages, d') <- case e of
-               Left dm  -> undefined {- run -} dcb dm
-               Right nm -> undefined {- run -} dcb nm
-       undefined -- send_client_messages client_messages
+       d' <- case e of
+               Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
+                              mapM_ (sendClientMessage h) client_messages
+                              return d'
+               Right nm -> callNightCallback ncb ps' d nm

        loop ps' d'
 
 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
        loop ps' d'
 
 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)


@@ -108,6 +164,18 @@ getNextUserMessage h ps = do
                DayMessage dm -> return (Left dm, ps')
                NightMessage nm -> return (Right nm, ps')
 
                DayMessage dm -> return (Left dm, ps')
                NightMessage nm -> return (Right nm, ps')
 

+parseIncomingMessage :: String -> IncomingMessage
+parseIncomingMessage = undefined
+
+sendClientMessage :: Handle -> ClientMessage -> IO ()
+sendClientMessage h msg = hPutStrLn h (toString msg)
+  where toString (Goto place)                    = unwords ["goto", show place]
+        toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
+        toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
+        toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
+        toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
+
+

 -- Convenience functions for accessing the state
 
 whoIsHere :: (MonadReader ParttyState m) => m [Player]
 -- Convenience functions for accessing the state
 
 whoIsHere :: (MonadReader ParttyState m) => m [Player]