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