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                      | PlayerAt Player Place
  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                      | NightStarts
  49                      | NightEndsIn Int
  50                      | NightEnds
  51                      | GotScore Score
  52                      deriving (Show, Eq)
  53 -- Pure bookkeeping events
  54 data InternalMessage = MyPlayerId Player
  55                      | Welcome
  56                      | PlayerJoined String
  57                      | GameStarting
  58                      | MyIdIs Player
  59                      | PlayerEnter Player Place
  60                      | PlayerLeave Player Place
  61                      | ActionsLeft Int
  62                      | Noise
  63                      deriving (Show, Eq)
  64
  65
  66 {- Einzusortieren:
  67                      | PlayerJoined Player  -- the game
  68                      | PlayerLeft Player
  69                      | PlayerEnters Player Place
  70                      | PlayerLeaves Player Place
  71                      | GotHint Hint
  72                      | PlayerList [Player]
  73                      | PlayerScore [(Player, Int)]
  74                      | PlayerNames [(Player, String)]
  75                      | GameStarted
  76                      | DayStarts
  77                      | DayEndsIn Int
  78                      | DayEnds
  79                      | NightStarts
  80                      | NightEndsIn Int
  81                      | NightEnds
  82                      | GameEnded
  83                      | PartyHint Place
  84                      | PlayerPosition Player Place -- wann bekommt man das?
  85                      | ActionsLeft Int
  86                      | NewContact Player
  87 -}
  88
  89 data ClientMessage = Tell Player Hint
  90                    | Goto Place
  91                      deriving (Show, Eq)
  92
  93 type DayCallback d   = DayMessage -> DayMonad d ()
  94 type NightCallback d = NightMessage -> NightMonad d ()
  95
  96 data ParttyState = ParttyState
  97         { psMyName      :: Player
  98         , psDay         :: Day
  99         , psPlayerInfo  :: Map Player PlayerInformation
 100         , psPartyHistory:: [(Day,Place)]
 101         , psPlace       :: Place
 102         , psPlayers     :: [Player]
 103         }
 104
 105 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
 106 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
 107
 108
 109 -- Start
 110
 111 -- Hostname, Port, Playername, Password, Callback
 112 runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
 113 runPartty host port username password dcb ncb initialData = do
 114         h <- connectTo host (PortNumber (fromIntegral port))
 115         hSetBuffering h LineBuffering
 116         putStrLn $ "Connected to " ++ host
 117         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
 118         hPutStrLn h $ unwords ["login", username, password]
 119         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
 120         when (myName /= username) $ error "Server returned a different name for me"
 121
 122         -- login has been successful, wait for the server start event
 123         fix $ \loop -> do
 124                 msg <- parseIncomingMessage `liftM` hGetLine h
 125                 case msg of
 126                         (InternalMessage GameStarting) -> return ()
 127                         otherwise                      -> do
 128                                 putStrLn "Waiting for game start..."
 129                                 loop
 130
 131         -- We expect two more fixed events. If the server changes, this breaks!
 132
 133         InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
 134         InternalMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
 135         when (player /= myId) $ error "Server did not tell us where we start"
 136         putStrLn $ "Starting at " ++ show startPlace
 137
 138         let initialState = ParttyState
 139                 { psMyName      = myId
 140                 , psDay         = 0
 141                 , psPlayerInfo  = empty
 142                 , psPartyHistory= []
 143                 , psPlace       = startPlace
 144                 , psPlayers     = []
 145                 }
 146
 147         -- The rest of the events are handled in the regular loop. Run the initial event
 148         -- and call the runner
 149
 150         d' <- callNightCallback ncb initialState initialData Initialize
 151
 152         runner h dcb ncb initialState d'
 153
 154 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
 155 callDayCallback dcb ps d e = do
 156         flip runStateT d $
 157                 flip runReaderT ps $ do
 158                         execWriterT $ do
 159                                 dcb e
 160
 161 callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
 162 callNightCallback ncb ps d e = do
 163         flip execStateT d $
 164                 flip runReaderT ps $ do
 165                         ncb e
 166
 167
 168 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
 169 runner h dcb ncb = fix $ \loop ps d -> do
 170         (e,ps') <- getNextUserMessage h ps
 171         d' <- case e of
 172                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
 173                                mapM_ (sendClientMessage h) client_messages
 174                                return d'
 175                 Right nm -> callNightCallback ncb ps' d nm
 176         loop ps' d'
 177
 178 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
 179 getNextUserMessage h ps = do
 180         line <- hGetLine h
 181         let msg = parseIncomingMessage line
 182         let ps' = updateState msg ps
 183         case msg of
 184                 InternalMessage ue -> getNextUserMessage h ps'
 185                 UnknownMessage s-> do putStrLn $"Got an unknown message:\n"++s
 186                                       getNextUserMessage h ps'
 187                 DayMessage dm -> return (Left dm, ps')
 188                 NightMessage nm -> return (Right nm, ps')
 189
 190 -- Message parsing
 191
 192 parseIncomingMessage :: String -> IncomingMessage
 193 parseIncomingMessage msg = case id of
 194         -- Errors, no proper handling for now
 195         07 -> error "Game is already in progress, try again later..."
 196
 197         -- Regular Messages
 198         71 -> InternalMessage (Welcome)
 199         20 -> InternalMessage (PlayerJoined s1)
 200         70 -> InternalMessage (Noise) -- welcome
 201         40 -> InternalMessage (Noise) -- waiting for at least .. players
 202         41 -> InternalMessage (Noise) -- game will start in...
 203         42 -> InternalMessage (GameStarting)
 204         43 -> InternalMessage (MyIdIs s1)
 205         22 -> InternalMessage (PlayerEnter s1 int2)
 206         23 -> InternalMessage (PlayerLeave s1 int2)
 207         65 -> InternalMessage (ActionsLeft int1)
 208
 209         50 -> DayMessage      (DayStarts)
 210         51 -> DayMessage      (DayEndsIn int1)
 211         52 -> DayMessage      (DayEnds)
 212         61 -> DayMessage      (PlayerAt s1 int2)
 213
 214         53 -> NightMessage    (NightStarts)
 215         54 -> NightMessage    (NightEndsIn int1)
 216         55 -> NightMessage    (NightEnds)
 217         62 -> NightMessage    (GotScore NoScore)
 218         63 -> NightMessage    (GotScore ToFew)
 219         64 -> NightMessage    (GotScore Scored)
 220
 221         60 -> NightMessage    (PartyHint int1)
 222
 223
 224         _  -> UnknownMessage msg
 225         --_  -> error $ "Unkown or unparseable message:\n" ++ msg
 226  where (id_s : num_params : rest) = words msg
 227        id = read id_s
 228        param_s = take (read num_params) rest
 229        s1   = read (param_s !! 0) :: String
 230        int1 = read (param_s !! 0) :: Int
 231        s2   = read (param_s !! 1) :: String
 232        int2 = read (param_s !! 1) :: Int
 233
 234 sendClientMessage :: Handle -> ClientMessage -> IO ()
 235 sendClientMessage h msg = do putStrLn $ "Client says: " ++ (show msg)
 236                              hPutStrLn h (toString msg)
 237   where toString (Goto place)                    = unwords ["goto", show place]
 238         toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
 239         toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
 240         toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
 241         toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
 242
 243 -- Bookkeeping
 244
 245 updateState :: IncomingMessage -> ParttyState -> ParttyState
 246 updateState msg ps = ps -- TODO: this is a stub
 247
 248
 249 -- Convenience functions for accessing the state
 250
 251 whoIsHere :: (MonadReader ParttyState m) => m [Player]
 252 whoIsHere = asks psPlayers
 253
 254 gameDay :: (MonadReader ParttyState m) => m Day
 255 gameDay = asks psDay
 256
 257 -- Interaction:
 258
 259 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
 260 send msg = tell [msg]
 261
 262