Refactor
[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 Score = NoScore | ToFew | Scored
23                      deriving (Show, Eq)
24
25 data IncomingMessage = InternalMessage InternalMessage
26                      | DayMessage      DayMessage
27                      | NightMessage    NightMessage
28                      | UnknownMessage  String
29                      deriving (Show, Eq)
30         
31 -- Events that we want to send to the user code and that
32 -- can be reacted upon
33 data DayMessage      = DayStarts Int
34                      | DayEndsIn Int
35                      | DayEnds
36                      | GotHint Player Hint
37                      deriving (Show, Eq)
38
39 -- Events that we want to send to the user code and that
40 -- can NOT be reacted upon
41 data NightMessage    = Initialize
42                      | PartyHint Place
43                      | PlayerAt Player Place
44                      | NightStarts
45                      | NightEndsIn Int
46                      | NightEnds
47                      | GotScore Score
48                      | NewContact Player
49                      | LostContact Player
50                      deriving (Show, Eq)
51 -- Pure bookkeeping events
52 data InternalMessage = MyPlayerId Player
53                      | Welcome
54                      | PlayerJoined String
55                      | PlayerLeft String
56                      | GameStarting
57                      | GameEnds
58                      | MyIdIs Player
59                      | PlayerEnter Player Place
60                      | PlayerLeave Player Place
61                      | ActionsLeft Int
62                      | Noise
63                      deriving (Show, Eq)
64
65
66 data ClientMessage = Tell Player Hint
67                    | Goto Place
68                      deriving (Show, Eq)
69
70 type DayCallback d   = DayMessage -> DayMonad d ()
71 type NightCallback d = NightMessage -> NightMonad d ()
72
73 data PlayerInformation = PlayerInformation
74         { piSeen        :: [Day]
75         , piHints       :: [(Day,Hint)]
76         }
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  = error "psPlayerInfo not implemented"
124                 , psPartyHistory= error "psPartyHistory not implemented"
125                 , psPlace       = startPlace
126                 , psPlayers     = error "psPlayers not implemented"
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',ps'') <- case e of
154                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
155                                mapM_ (sendClientMessage h) client_messages
156                                let ps'' = foldr updateStateC ps' client_messages
157                                return (d',ps'')
158                 Right nm -> do d' <- callNightCallback ncb ps' d nm
159                                return (d',ps')
160         loop ps'' d'
161
162 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
163 getNextUserMessage h ps = do
164         msg <- getNextMessage h
165         let ps' = updateState msg ps
166         case msg of
167                 InternalMessage ue -> getNextUserMessage h ps'
168                 UnknownMessage s-> do putStrLn $"Got an unknown message:\n"++s
169                                       getNextUserMessage h ps'
170                 DayMessage dm -> return (Left dm, ps')
171                 NightMessage nm -> return (Right nm, ps')
172
173 -- Message parsing
174
175 getNextMessage :: Handle -> IO (IncomingMessage)
176 getNextMessage h = do
177         line <- hGetLine h
178         let msg = parseIncomingMessage line
179         return msg
180
181 parseIncomingMessage :: String -> IncomingMessage
182 parseIncomingMessage msg = case id of
183         -- Errors, no proper handling for now
184         1 -> error "Invalid place parameter."
185         2 -> error "Invalid player parameter."
186         3 -> error "Login needed."
187         4 -> error "Cannot be used at night."
188         5 -> error "No actions left."
189         6 -> error "logged in twice."
190         7 -> error "Cannot login. Game is already running."
191         8 -> error "Invalid username/password."
192         9 -> error "Numeric value required."
193         10 -> error "Unknown command."
194         11 -> error "Invalid parameters."
195         12 -> error "<playerid> is unreachable."
196
197         -- Regular Messages
198         71 -> InternalMessage (Welcome)
199         20 -> InternalMessage (PlayerJoined s1)
200         21 -> InternalMessage (PlayerLeft s1)
201         70 -> InternalMessage (Noise) -- welcome
202         40 -> InternalMessage (Noise) -- waiting for at least .. players
203         41 -> InternalMessage (Noise) -- game will start in...
204         42 -> InternalMessage (GameStarting)
205         56 -> InternalMessage (GameEnds)
206         43 -> InternalMessage (MyIdIs s1)
207         22 -> InternalMessage (PlayerEnter s1 int2)
208         23 -> InternalMessage (PlayerLeave s1 int2)
209         65 -> InternalMessage (ActionsLeft int1)
210
211         50 -> DayMessage      (DayStarts int1)
212         51 -> DayMessage      (DayEndsIn int1)
213         52 -> DayMessage      (DayEnds)
214         24 -> DayMessage      (if int2 == 0 then GotHint s1 (NoPartyAt int3)
215                                             else GotHint s1 (PartyAt   int3) )
216         25 -> DayMessage      (if int2 == 0 then GotHint s1 (Liar      s3)
217                                             else GotHint s1 (NoLiar    s3) )
218
219         53 -> NightMessage    (NightStarts)
220         54 -> NightMessage    (NightEndsIn int1)
221         55 -> NightMessage    (NightEnds)
222
223         61 -> NightMessage    (PlayerAt s1 int2)
224         62 -> NightMessage    (GotScore NoScore)
225         63 -> NightMessage    (GotScore ToFew)
226         64 -> NightMessage    (GotScore Scored)
227         66 -> NightMessage    (NewContact s1)
228         67 -> NightMessage    (LostContact s1)
229
230         60 -> NightMessage    (PartyHint int1)
231
232         
233         --_  -> UnknownMessage msg
234         _  -> error $ "Unkown or unparseable message:\n" ++ msg
235  where (id_s : num_params : rest) = words msg
236        id = read id_s
237        param_s = take (read num_params) rest
238        -- This works thanks to laziness:
239        s1   = read (param_s !! 0) :: String
240        int1 = read (param_s !! 0) :: Int
241        s2   = read (param_s !! 1) :: String
242        int2 = read (param_s !! 1) :: Int
243        s3   = read (param_s !! 2) :: String
244        int3 = read (param_s !! 2) :: Int
245
246 sendClientMessage :: Handle -> ClientMessage -> IO ()
247 sendClientMessage h msg = do putStrLn $ "Client says: " ++ (show msg)
248                              hPutStrLn h (toString msg)
249   where toString (Goto place)                    = unwords ["goto", show place]
250         toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
251         toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
252         toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
253         toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
254
255 -- Bookkeeping
256
257 updateState :: IncomingMessage -> ParttyState -> ParttyState
258
259 updateState (DayMessage (DayStarts num)) ps =
260         ps {psDay = num}
261 updateState msg ps = ps -- TODO: this is a stub
262
263 updateStateC :: ClientMessage -> ParttyState -> ParttyState
264 updateStateC (Goto place) ps = ps {psPlace = place}
265 updateStateC msg ps = ps
266
267 -- Convenience functions for accessing the state
268
269 whoIsHere :: (MonadReader ParttyState m) => m [Player]
270 whoIsHere = asks psPlayers
271
272 gameDay :: (MonadReader ParttyState m) => m Day
273 gameDay = asks psDay
274
275 -- Interaction:
276
277 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
278 send msg = tell [msg]
279
280