6ef8381614a4dbd82b025d6a40b2c472ce5ed617
[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' <- case e of
191                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
192                                mapM_ (sendClientMessage h) client_messages
193                                return d'
194                 Right nm -> do callNightCallback ncb ps' d nm
195         loop ps' d'
196
197 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
198 getNextUserMessage h ps = do
199         msg <- getNextMessage h
200         let ps' = updateState msg ps
201         case msg of
202                 InternalMessage ue -> getNextUserMessage h ps'
203                 UnknownMessage s-> do putStrLn $"Got an unknown message:\n"++s
204                                       getNextUserMessage h ps'
205                 DayMessage dm -> return (Left dm, ps')
206                 NightMessage nm -> return (Right nm, ps')
207
208 -- Message parsing
209
210 getNextMessage :: Handle -> IO (IncomingMessage)
211 getNextMessage h = do
212         line <- hGetLine h
213         --putStrLn line
214         let msg = parseIncomingMessage line
215         case msg of
216                 LineEater n f -> f `liftM` sequence (replicate n (hGetLine h))
217                 msg           -> return msg
218
219 parseIncomingMessage :: String -> IncomingMessage
220 parseIncomingMessage msg = case id of
221         -- Errors, no proper handling for now
222         1  -> error "Invalid place parameter."
223         2  -> error "Invalid player parameter."
224         3  -> error "Login needed."
225         4  -> error "Cannot be used at night."
226         5  -> error "No actions left."
227         6  -> error "logged in twice."
228         7  -> error "Cannot login. Game is already running."
229         8  -> error "Invalid username/password."
230         9  -> error "Numeric value required."
231         10 -> error "Unknown command."
232         11 -> error "Invalid parameters."
233         12 -> error "<playerid> is unreachable."
234
235         -- Regular Messages
236         71 -> InternalMessage (Welcome)
237         20 -> InternalMessage (PlayerJoined s1)
238         21 -> InternalMessage (PlayerLeft s1)
239         70 -> InternalMessage (Noise) -- welcome
240         40 -> InternalMessage (Noise) -- waiting for at least .. players
241         41 -> InternalMessage (Noise) -- game will start in...
242         42 -> InternalMessage (GameStarting)
243         56 -> InternalMessage (GameEnds)
244         43 -> InternalMessage (MyIdIs s1)
245         65 -> InternalMessage (ActionsLeft int1)
246
247         50 -> DayMessage      (DayStarts int1)
248         51 -> DayMessage      (DayEndsIn int1)
249         52 -> DayMessage      (DayEnds)
250
251         22 -> DayMessage      (PlayerEnter s1 int2)
252         23 -> DayMessage      (PlayerLeave s1 int2)
253
254         24 -> DayMessage      (if int2 == 0 then GotHint s1 (NoPartyAt int3)
255                                             else GotHint s1 (PartyAt   int3) )
256         25 -> DayMessage      (if int2 == 0 then GotHint s1 (Liar      s3)
257                                             else GotHint s1 (NoLiar    s3) )
258
259         53 -> NightMessage    (NightStarts)
260         54 -> NightMessage    (NightEndsIn int1)
261         55 -> NightMessage    (NightEnds)
262
263         61 -> NightMessage    (PlayerAt s1 int2)
264         62 -> NightMessage    (GotScore NoScore)
265         63 -> NightMessage    (GotScore ToFew)
266         64 -> NightMessage    (GotScore Scored)
267         66 -> NightMessage    (NewContact s1)
268         67 -> NightMessage    (LostContact s1)
269
270         60 -> NightMessage    (PartyHint int1)
271
272         30 -> LineEater int1 (\l -> InternalMessage (PlayerList (map parsePlayer l)))
273         32 -> LineEater int1 (\l -> InternalMessage (ScoreList  (map parseScore l)))
274         34 -> LineEater int1 (\l -> InternalMessage (NameList   (map parseName l)))
275
276         
277         --_  -> UnknownMessage msg
278         _  -> error $ "Unkown or unparseable message:\n" ++ msg
279  where (id_s : num_params : rest) = words msg
280        id = read id_s
281        param_s = take (read num_params) rest
282        -- This works thanks to laziness:
283        s1   = read (param_s !! 0) :: String
284        int1 = read (param_s !! 0) :: Int
285        s2   = read (param_s !! 1) :: String
286        int2 = read (param_s !! 1) :: Int
287        s3   = read (param_s !! 2) :: String
288        int3 = read (param_s !! 2) :: Int
289
290        parsePlayer str = read (words str !! 2)
291        parseScore str = (read (words str !! 2), read (words str !! 2))
292        parseName str = (read (words str !! 2), read (words str !! 2))
293
294 sendClientMessage :: Handle -> ClientMessage -> IO ()
295 sendClientMessage h msg = do putStrLn $ "       sending " ++ (show msg)
296                              hPutStrLn h (toString msg)
297   where toString (Goto place)                    = unwords ["goto", show place]
298         toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
299         toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
300         toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
301         toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
302
303 -- Bookkeeping
304
305 updateState :: IncomingMessage -> ParttyState -> ParttyState
306
307 updateState (DayMessage (DayStarts num)) ps =
308         ps {psDay = num}
309
310 updateState (DayMessage (PlayerLeave player place) ) ps =
311         if (player == psMyName ps)
312         then ps {psPlayersHere = []}
313         else ps {psPlayersHere = filter (/= player) (psPlayersHere ps) }
314
315 updateState (DayMessage (PlayerEnter player place) ) ps =
316         if (player == psMyName ps)
317         then ps {psPlace = place}
318         else ps {psPlayersHere = player :  psPlayersHere ps}
319
320 updateState (InternalMessage (PlayerList players) ) ps =
321         ps {psPlayers = players}
322
323 updateState (InternalMessage (PlayerJoined player) ) ps =
324         ps {psPlayers = player :  psPlayers ps}
325
326 updateState (InternalMessage (PlayerLeft player) ) ps =
327         ps {psPlayers = filter (/= player) (psPlayers ps) }
328
329 updateState (InternalMessage (ActionsLeft n)) ps =
330         ps {psActionsLeft = n }
331
332 updateState msg ps = ps -- TODO: this is a stub
333
334 -- Convenience functions for accessing the state
335
336 whoIsHere :: (MonadReader ParttyState m) => m [Player]
337 whoIsHere = asks psPlayers
338
339 gameDay :: (MonadReader ParttyState m) => m Day
340 gameDay = asks psDay
341
342 -- Interaction:
343
344 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
345 send msg = tell [msg]
346
347 -- Output
348
349 say :: (MonadIO m, MonadReader ParttyState m) => String -> m ()
350 say s = do 
351         name <- asks psLoginName
352         liftIO $ putStrLn $ "[" ++ name ++ "] " ++ s