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