Parsing all events, making parser errors fatal
[darcs-mirror-haskell-partty.git] / Partty.hs
1 {-# LANGUAGE FlexibleContexts #-}
2  
3 module Partty where
4
5 import Data.Map
6 import Control.Monad.State
7 import Control.Monad.Reader
8 import Control.Monad.Writer
9 import Network
10 import System.IO
11
12 type Player = String
13 type Day = Int
14 type Place = Int
15
16 data Hint = PartyAt Place
17           | NoPartyAt Place
18           | Liar Player
19           | NoLiar Player
20      deriving (Show, Eq)
21
22 data PlayerInformation = PlayerInformation
23         { piSeen        :: [Day]
24         , piHints       :: [(Day,Hint)]
25         }
26
27 data Score = NoScore | ToFew | Scored
28                      deriving (Show, Eq)
29
30 data IncomingMessage = InternalMessage InternalMessage
31                      | DayMessage      DayMessage
32                      | NightMessage    NightMessage
33                      | UnknownMessage  String
34                      deriving (Show, Eq)
35         
36 -- Events that we want to send to the user code and that
37 -- can be reacted upon
38 data DayMessage      = DayStarts
39                      | DayEndsIn Int
40                      | DayEnds
41                      | GotHint Player Hint
42                      deriving (Show, Eq)
43
44 -- Events that we want to send to the user code and that
45 -- can NOT be reacted upon
46 data NightMessage    = Initialize
47                      | PartyHint Place
48                      | PlayerAt Player Place
49                      | NightStarts
50                      | NightEndsIn Int
51                      | NightEnds
52                      | GotScore Score
53                      | NewContact Player
54                      | LostContact Player
55                      deriving (Show, Eq)
56 -- Pure bookkeeping events
57 data InternalMessage = MyPlayerId Player
58                      | Welcome
59                      | PlayerJoined String
60                      | PlayerLeft String
61                      | GameStarting
62                      | GameEnds
63                      | MyIdIs Player
64                      | PlayerEnter Player Place
65                      | PlayerLeave Player Place
66                      | ActionsLeft Int
67                      | Noise
68                      deriving (Show, Eq)
69
70
71 data ClientMessage = Tell Player Hint
72                    | Goto Place
73                      deriving (Show, Eq)
74
75 type DayCallback d   = DayMessage -> DayMonad d ()
76 type NightCallback d = NightMessage -> NightMonad d ()
77
78 data ParttyState = ParttyState
79         { psMyName      :: Player
80         , psDay         :: Day
81         , psPlayerInfo  :: Map Player PlayerInformation
82         , psPartyHistory:: [(Day,Place)]
83         , psPlace       :: Place
84         , psPlayers     :: [Player]
85         }
86
87 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
88 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
89
90
91 -- Start
92
93 -- Hostname, Port, Playername, Password, Callback
94 runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
95 runPartty host port username password dcb ncb initialData = do 
96         h <- connectTo host (PortNumber (fromIntegral port))
97         hSetBuffering h LineBuffering
98         putStrLn $ "Connected to " ++ host
99         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
100         hPutStrLn h $ unwords ["login", username, password]
101         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
102         when (myName /= username) $ error "Server returned a different name for me"
103
104         -- login has been successful, wait for the server start event
105         fix $ \loop -> do
106                 msg <- parseIncomingMessage `liftM` hGetLine h
107                 case msg of 
108                         (InternalMessage GameStarting) -> return ()
109                         otherwise                      -> do
110                                 putStrLn "Waiting for game start..."
111                                 loop
112         
113         -- We expect two more fixed events. If the server changes, this breaks!
114         
115         InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
116         InternalMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
117         when (player /= myId) $ error "Server did not tell us where we start"
118         putStrLn $ "Starting at " ++ show startPlace
119
120         let initialState = ParttyState
121                 { psMyName      = myId
122                 , psDay         = 0
123                 , psPlayerInfo  = empty
124                 , psPartyHistory= []
125                 , psPlace       = startPlace
126                 , psPlayers     = []
127                 }
128
129         -- The rest of the events are handled in the regular loop. Run the initial event
130         -- and call the runner
131         
132         d' <- callNightCallback ncb initialState initialData Initialize
133
134         runner h dcb ncb initialState d'
135
136 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
137 callDayCallback dcb ps d e = do
138         flip runStateT d $
139                 flip runReaderT ps $ do
140                         execWriterT $ do
141                                 dcb e
142
143 callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
144 callNightCallback ncb ps d e = do
145         flip execStateT d $
146                 flip runReaderT ps $ do
147                         ncb e
148                                 
149
150 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
151 runner h dcb ncb = fix $ \loop ps d -> do
152         (e,ps') <- getNextUserMessage h ps
153         d' <- case e of
154                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
155                                mapM_ (sendClientMessage h) client_messages
156                                return d'
157                 Right nm -> callNightCallback ncb ps' d nm
158         loop ps' d'
159
160 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
161 getNextUserMessage h ps = do
162         line <- hGetLine h
163         let msg = parseIncomingMessage line
164         let ps' = updateState msg ps
165         case msg of
166                 InternalMessage ue -> getNextUserMessage h ps'
167                 UnknownMessage s-> do putStrLn $"Got an unknown message:\n"++s
168                                       getNextUserMessage h ps'
169                 DayMessage dm -> return (Left dm, ps')
170                 NightMessage nm -> return (Right nm, ps')
171
172 -- Message parsing
173
174 parseIncomingMessage :: String -> IncomingMessage
175 parseIncomingMessage msg = case id of
176         -- Errors, no proper handling for now
177         1 -> error "Invalid place parameter."
178         2 -> error "Invalid player parameter."
179         3 -> error "Login needed."
180         4 -> error "Cannot be used at night."
181         5 -> error "No actions left."
182         6 -> error "logged in twice."
183         7 -> error "Cannot login. Game is already running."
184         8 -> error "Invalid username/password."
185         9 -> error "Numeric value required."
186         10 -> error "Unknown command."
187         11 -> error "Invalid parameters."
188         12 -> error "<playerid> is unreachable."
189
190         -- Regular Messages
191         71 -> InternalMessage (Welcome)
192         20 -> InternalMessage (PlayerJoined s1)
193         21 -> InternalMessage (PlayerLeft s1)
194         70 -> InternalMessage (Noise) -- welcome
195         40 -> InternalMessage (Noise) -- waiting for at least .. players
196         41 -> InternalMessage (Noise) -- game will start in...
197         42 -> InternalMessage (GameStarting)
198         56 -> InternalMessage (GameEnds)
199         43 -> InternalMessage (MyIdIs s1)
200         22 -> InternalMessage (PlayerEnter s1 int2)
201         23 -> InternalMessage (PlayerLeave s1 int2)
202         65 -> InternalMessage (ActionsLeft int1)
203
204         50 -> DayMessage      (DayStarts)
205         51 -> DayMessage      (DayEndsIn int1)
206         52 -> DayMessage      (DayEnds)
207         24 -> DayMessage      (if int2 == 0 then GotHint s1 (NoPartyAt int3)
208                                             else GotHint s1 (PartyAt   int3) )
209         25 -> DayMessage      (if int2 == 0 then GotHint s1 (Liar      s3)
210                                             else GotHint s1 (NoLiar    s3) )
211
212         53 -> NightMessage    (NightStarts)
213         54 -> NightMessage    (NightEndsIn int1)
214         55 -> NightMessage    (NightEnds)
215
216         61 -> NightMessage    (PlayerAt s1 int2)
217         62 -> NightMessage    (GotScore NoScore)
218         63 -> NightMessage    (GotScore ToFew)
219         64 -> NightMessage    (GotScore Scored)
220         66 -> NightMessage    (NewContact s1)
221         67 -> NightMessage    (LostContact s1)
222
223         60 -> NightMessage    (PartyHint int1)
224
225         
226         --_  -> UnknownMessage msg
227         _  -> error $ "Unkown or unparseable message:\n" ++ msg
228  where (id_s : num_params : rest) = words msg
229        id = read id_s
230        param_s = take (read num_params) rest
231        -- This works thanks to laziness:
232        s1   = read (param_s !! 0) :: String
233        int1 = read (param_s !! 0) :: Int
234        s2   = read (param_s !! 1) :: String
235        int2 = read (param_s !! 1) :: Int
236        s3   = read (param_s !! 2) :: String
237        int3 = read (param_s !! 2) :: Int
238
239 sendClientMessage :: Handle -> ClientMessage -> IO ()
240 sendClientMessage h msg = do putStrLn $ "Client says: " ++ (show msg)
241                              hPutStrLn h (toString msg)
242   where toString (Goto place)                    = unwords ["goto", show place]
243         toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
244         toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
245         toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
246         toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
247
248 -- Bookkeeping
249
250 updateState :: IncomingMessage -> ParttyState -> ParttyState
251 updateState msg ps = ps -- TODO: this is a stub
252
253
254 -- Convenience functions for accessing the state
255
256 whoIsHere :: (MonadReader ParttyState m) => m [Player]
257 whoIsHere = asks psPlayers
258
259 gameDay :: (MonadReader ParttyState m) => m Day
260 gameDay = asks psDay
261
262 -- Interaction:
263
264 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
265 send msg = tell [msg]
266
267